diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index 7ccf322c..c01c5bf1 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -188,363 +188,739 @@ module psb_c_vect_mod class(psb_c_base_vect_type), allocatable, target,& & save, private :: psb_c_base_vect_default + + interface + module function c_vect_get_dupl(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_vect_get_dupl + end interface + + interface + module subroutine c_vect_set_dupl(x,val) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine c_vect_set_dupl + end interface + + interface + module function c_vect_get_ncfs(x) result(res) + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_vect_get_ncfs + end interface + + interface + module subroutine c_vect_set_ncfs(x,val) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine c_vect_set_ncfs + end interface + + interface + module function c_vect_get_state(x) result(res) + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_vect_get_state + end interface + + interface + module function c_vect_is_null(x) result(res) + class(psb_c_vect_type), intent(in) :: x + logical :: res + end function c_vect_is_null + end interface + + interface + module function c_vect_is_bld(x) result(res) + class(psb_c_vect_type), intent(in) :: x + logical :: res + end function c_vect_is_bld + end interface + + interface + module function c_vect_is_upd(x) result(res) + class(psb_c_vect_type), intent(in) :: x + logical :: res + end function c_vect_is_upd + end interface + + interface + module function c_vect_is_asb(x) result(res) + class(psb_c_vect_type), intent(in) :: x + logical :: res + end function c_vect_is_asb + end interface + + interface + module subroutine c_vect_set_state(n,x) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine c_vect_set_state + end interface + + interface + module subroutine c_vect_set_null(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_set_null + end interface + + interface + module subroutine c_vect_set_bld(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_set_bld + end interface + + interface + module subroutine c_vect_set_upd(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_set_upd + end interface + + interface + module subroutine c_vect_set_asb(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_set_asb + end interface + + interface + module function c_vect_get_nrmv(x) result(res) + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_vect_get_nrmv + end interface + + interface + module subroutine c_vect_set_nrmv(x,val) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine c_vect_set_nrmv + end interface + + interface + module function c_vect_is_remote_build(x) result(res) + class(psb_c_vect_type), intent(in) :: x + logical :: res + end function c_vect_is_remote_build + end interface + + interface + module subroutine c_vect_set_remote_build(x,val) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine c_vect_set_remote_build + end interface + interface psb_set_vect_default - module procedure psb_c_set_vect_default - end interface psb_set_vect_default + module subroutine psb_c_set_vect_default(v) + class(psb_c_base_vect_type), intent(in) :: v + end subroutine psb_c_set_vect_default + end interface interface psb_get_vect_default - module procedure psb_c_get_vect_default - end interface psb_get_vect_default - + module function psb_c_get_vect_default(v) result(res) + class(psb_c_vect_type), intent(in) :: v + class(psb_c_base_vect_type), pointer :: res + end function psb_c_get_vect_default + end interface + + interface + module subroutine psb_c_clear_vect_default() + end subroutine psb_c_clear_vect_default + end interface + + interface + module function psb_c_get_base_vect_default() result(res) + class(psb_c_base_vect_type), pointer :: res + end function psb_c_get_base_vect_default + end interface + + interface + module subroutine c_vect_clone(x,y,info) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_clone + end interface + + interface + module subroutine c_vect_bld_x(x,invect,mold,scratch) + complex(psb_spk_), intent(in) :: invect(:) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine c_vect_bld_x + end interface + + interface + module subroutine c_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine c_vect_bld_mn + end interface + + interface + module subroutine c_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine c_vect_bld_en + end interface + + interface + module function c_vect_get_vect(x,n) result(res) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function c_vect_get_vect + end interface + + interface + module subroutine c_vect_set_scal(x,val,first,last) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine c_vect_set_scal + end interface + + interface + module subroutine c_vect_set_vect(x,val,first,last) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine c_vect_set_vect + end interface + + interface + module subroutine c_vect_check_addr(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_check_addr + end interface + + interface + module function c_vect_get_nrows(x) result(res) + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_vect_get_nrows + end interface + + interface + module function c_vect_sizeof(x) result(res) + class(psb_c_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function c_vect_sizeof + end interface + + interface + module function c_vect_get_fmt(x) result(res) + class(psb_c_vect_type), intent(in) :: x + character(len=5) :: res + end function c_vect_get_fmt + end interface + + interface + module subroutine c_vect_all(n, x, info, mold) + 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 + end subroutine c_vect_all + end interface + + interface + module subroutine c_vect_reinit(x, info, clear) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine c_vect_reinit + end interface + + interface + module subroutine c_vect_reall(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_reall + end interface + + interface + module subroutine c_vect_zero(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_zero + end interface + + interface + module subroutine c_vect_asb(n, x, info, scratch) + integer(psb_ipk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine c_vect_asb + end interface + + interface + module subroutine c_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_vect_type) :: x + end subroutine c_vect_gthab + end interface + + interface + module subroutine c_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_vect_type) :: x + end subroutine c_vect_gthzv + end interface + + interface + module subroutine c_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_vect_type) :: y + end subroutine c_vect_sctb + end interface + + interface + module subroutine c_vect_free(x, info) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_free + end interface + + interface + module subroutine c_vect_ins_a(n,irl,val,x,maxr,info) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_ins_a + end interface + + interface + module subroutine c_vect_ins_v(n,irl,val,x,maxr,info) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_c_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_ins_v + end interface + + interface + module subroutine c_vect_cnv(x,mold) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + class(psb_c_base_vect_type), allocatable :: tmp + end subroutine c_vect_cnv + end interface + + interface + module subroutine c_vect_sync(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_sync + end interface + + interface + module subroutine c_vect_set_sync(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_set_sync + end interface + + interface + module subroutine c_vect_set_host(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_set_host + end interface + + interface + module subroutine c_vect_set_dev(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_set_dev + end interface + + interface + module function c_vect_is_sync(x) result(res) + logical :: res + class(psb_c_vect_type), intent(inout) :: x + end function c_vect_is_sync + end interface + + interface + module function c_vect_is_host(x) result(res) + logical :: res + class(psb_c_vect_type), intent(inout) :: x + end function c_vect_is_host + end interface + + interface + module function c_vect_is_dev(x) result(res) + logical :: res + class(psb_c_vect_type), intent(inout) :: x + end function c_vect_is_dev + end interface + + + interface + module function c_vect_get_entry(x,index) result(res) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: res + end function c_vect_get_entry + end interface + + interface + module subroutine c_vect_set_entry(x,index,val) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + end subroutine c_vect_set_entry + end interface + + interface + module function c_vect_dot_v(n,x,y) result(res) + class(psb_c_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + end function c_vect_dot_v + end interface + + interface + module function c_vect_dot_a(n,x,y) result(res) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + end function c_vect_dot_a + end interface + + interface + module subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_axpby_v + end interface + + interface + module subroutine c_vect_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_axpby_v2 + end interface + + interface + module subroutine c_vect_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_axpby_a + end interface + + interface + module subroutine c_vect_axpby_a2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_axpby_a2 + end interface + + interface + module subroutine c_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_upd_xyz + end interface + + interface + module subroutine c_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + class(psb_c_vect_type), intent(inout) :: w + complex(psb_spk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_xyzw + end interface + + interface + module subroutine c_vect_mlt_v(x, y, info) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_mlt_v + end interface + + interface + module subroutine c_vect_mlt_a(x, y, info) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_mlt_a + end interface + + interface + module subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: y(:) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_mlt_a_2 + end interface + + interface + module subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_spk_), intent(in) :: alpha,beta + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine c_vect_mlt_v_2 + end interface + + interface + module subroutine c_vect_mlt_av(alpha,x,y,beta,z,info) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_mlt_av + end interface + + interface + module subroutine c_vect_mlt_va(alpha,x,y,beta,z,info) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_mlt_va + end interface + + interface + module subroutine c_vect_div_v(x, y, info) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_div_v + end interface + + interface + module subroutine c_vect_div_v2( x, y, z, info) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_div_v2 + end interface + + interface + module subroutine c_vect_div_v_check(x, y, info, flag) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_vect_div_v_check + end interface + + interface + module subroutine c_vect_div_v2_check(x, y, z, info, flag) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_vect_div_v2_check + end interface + + interface + module subroutine c_vect_div_a2(x, y, z, info) + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_div_a2 + end interface + + interface + module subroutine c_vect_div_a2_check(x, y, z, info,flag) + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_vect_div_a2_check + end interface + + interface + module subroutine c_vect_inv_v(x, y, info) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_inv_v + end interface + + interface + module subroutine c_vect_inv_v_check(x, y, info, flag) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_vect_inv_v_check + end interface + + interface + module subroutine c_vect_inv_a2(x, y, info) + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_inv_a2 + end interface + + interface + module subroutine c_vect_inv_a2_check(x, y, info,flag) + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_vect_inv_a2_check + end interface + + interface + module subroutine c_vect_acmp_a2(x,c,z,info) + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_acmp_a2 + end interface + + interface + module subroutine c_vect_acmp_v2(x,c,z,info) + real(psb_spk_), intent(in) :: c + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_acmp_v2 + end interface + + interface + module subroutine c_vect_scal(alpha, x) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent (in) :: alpha + end subroutine c_vect_scal + end interface + + interface + module subroutine c_vect_absval1(x) + class(psb_c_vect_type), intent(inout) :: x + end subroutine c_vect_absval1 + end interface + + interface + module subroutine c_vect_absval2(x,y) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + end subroutine c_vect_absval2 + end interface + + interface + module function c_vect_nrm2(n,x) result(res) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function c_vect_nrm2 + end interface + + interface + module function c_vect_nrm2_weight(n,x,w,aux) result(res) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: w + class(psb_c_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function c_vect_nrm2_weight + end interface + + interface + module function c_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: w + class(psb_c_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_c_vect_type), intent(inout), optional :: aux + end function c_vect_nrm2_weight_mask + end interface + + interface + module function c_vect_amax(n,x) result(res) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function c_vect_amax + end interface + + + interface + module function c_vect_asum(n,x) result(res) + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function c_vect_asum + end interface + + + + interface + module subroutine c_vect_addconst_a2(x,b,z,info) + real(psb_spk_), intent(in) :: b + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_addconst_a2 + end interface + + interface + module subroutine c_vect_addconst_v2(x,b,z,info) + real(psb_spk_), intent(in) :: b + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_vect_addconst_v2 + end interface contains - function c_vect_get_dupl(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_dupl() - else - res = psb_dupl_null_ - end if - end function c_vect_get_dupl - - subroutine c_vect_set_dupl(x,val) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_dupl(val) - else - call x%v%set_dupl(psb_dupl_def_) - end if - end if - end subroutine c_vect_set_dupl - - function c_vect_get_ncfs(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_ncfs() - else - res = 0 - end if - end function c_vect_get_ncfs - - subroutine c_vect_set_ncfs(x,val) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_ncfs(val) - else - call x%v%set_ncfs(0) - end if - end if - end subroutine c_vect_set_ncfs - - function c_vect_get_state(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_state() - else - res = psb_vect_null_ - end if - end function c_vect_get_state - - function c_vect_is_null(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_null_) - end function c_vect_is_null - - function c_vect_is_bld(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_bld_) - end function c_vect_is_bld - - function c_vect_is_upd(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_upd_) - end function c_vect_is_upd - - function c_vect_is_asb(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_asb_) - end function c_vect_is_asb - - subroutine c_vect_set_state(n,x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - if (allocated(x%v)) then - call x%v%set_state(n) - end if - end subroutine c_vect_set_state - - - subroutine c_vect_set_null(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_null_) - end subroutine c_vect_set_null - - subroutine c_vect_set_bld(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_bld_) - end subroutine c_vect_set_bld - - subroutine c_vect_set_upd(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_upd_) - end subroutine c_vect_set_upd - - subroutine c_vect_set_asb(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_asb_) - end subroutine c_vect_set_asb - - 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 - class(psb_c_vect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function c_vect_is_remote_build - - subroutine c_vect_set_remote_build(x,val) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine c_vect_set_remote_build - - subroutine psb_c_set_vect_default(v) - implicit none - class(psb_c_base_vect_type), intent(in) :: v - - if (allocated(psb_c_base_vect_default)) then - deallocate(psb_c_base_vect_default) - end if - allocate(psb_c_base_vect_default, mold=v) - - end subroutine psb_c_set_vect_default - - function psb_c_get_vect_default(v) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: v - class(psb_c_base_vect_type), pointer :: res - - res => psb_c_get_base_vect_default() - - end function psb_c_get_vect_default - - subroutine psb_c_clear_vect_default() - implicit none - - if (allocated(psb_c_base_vect_default)) then - deallocate(psb_c_base_vect_default) - end if - - end subroutine psb_c_clear_vect_default - - function psb_c_get_base_vect_default() result(res) - implicit none - class(psb_c_base_vect_type), pointer :: res - - if (.not.allocated(psb_c_base_vect_default)) then - allocate(psb_c_base_vect_type :: psb_c_base_vect_default) - end if - - res => psb_c_base_vect_default - - end function psb_c_get_base_vect_default - - subroutine c_vect_clone(x,y,info) - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - ! - ! Using sourced allocation here creates - ! problems with handling of memory allocated - ! elsewhere (e.g. accelerators), hence delegation - ! to %bld method - ! - call y%bld(x%get_vect(),mold=x%v) - end if - end subroutine c_vect_clone - - subroutine c_vect_bld_x(x,invect,mold,scratch) - complex(psb_spk_), intent(in) :: invect(:) - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) - - end subroutine c_vect_bld_x - - - subroutine c_vect_bld_mn(x,n,mold,scratch) - integer(psb_mpk_), intent(in) :: n - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - class(psb_c_base_vect_type), pointer :: mld - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine c_vect_bld_mn - - subroutine c_vect_bld_en(x,n,mold,scratch) - integer(psb_epk_), intent(in) :: n - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine c_vect_bld_en - - function c_vect_get_vect(x,n) result(res) - class(psb_c_vect_type), intent(inout) :: x - complex(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - - if (allocated(x%v)) then - res = x%v%get_vect(n) - end if - end function c_vect_get_vect - - subroutine c_vect_set_scal(x,val,first,last) - class(psb_c_vect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine c_vect_set_scal - - subroutine c_vect_set_vect(x,val,first,last) - class(psb_c_vect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine c_vect_set_vect - - subroutine c_vect_check_addr(x) - class(psb_c_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%check_addr() - - end subroutine c_vect_check_addr - function constructor(x) result(this) complex(psb_spk_) :: x(:) type(psb_c_vect_type) :: this @@ -566,912 +942,8 @@ contains end function size_const - function c_vect_get_nrows(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function c_vect_get_nrows - - function c_vect_sizeof(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function c_vect_sizeof - - function c_vect_get_fmt(x) result(res) - implicit none - class(psb_c_vect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function c_vect_get_fmt - - 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 - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_c_base_vect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(n,info) - else - info = psb_err_alloc_dealloc_ - end if - call x%set_bld() - end subroutine c_vect_all - - subroutine c_vect_reinit(x, info, clear) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - - if (allocated(x%v)) call x%v%reinit(info,clear) - call x%set_upd() - - end subroutine c_vect_reinit - - subroutine c_vect_reall(n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(n,info) - if (info == 0) & - & call x%asb(n,info) - - end subroutine c_vect_reall - - subroutine c_vect_zero(x) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine c_vect_zero - - subroutine c_vect_asb(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - if (allocated(x%v)) then - call x%v%asb(n,info,scratch=scratch) - call x%set_asb() - end if - end subroutine c_vect_asb - - subroutine c_vect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: alpha, beta, y(:) - class(psb_c_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine c_vect_gthab - - subroutine c_vect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: y(:) - class(psb_c_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine c_vect_gthzv - - subroutine c_vect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: beta, x(:) - class(psb_c_vect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine c_vect_sctb - - subroutine c_vect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine c_vect_free - - subroutine c_vect_ins_a(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine c_vect_ins_a - - subroutine c_vect_ins_v(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - 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, 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,maxr,info) - - end subroutine c_vect_ins_v - - - subroutine c_vect_cnv(x,mold) - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(in), optional :: mold - class(psb_c_base_vect_type), allocatable :: tmp - - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info,mold=psb_c_get_base_vect_default()) - end if - if (allocated(x%v)) then - if (allocated(x%v%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%base_cpy(tmp) - call x%v%free(info) - endif - end if - call move_alloc(tmp,x%v) - - end subroutine c_vect_cnv - - - subroutine c_vect_sync(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine c_vect_sync - - subroutine c_vect_set_sync(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_sync() - - end subroutine c_vect_set_sync - - subroutine c_vect_set_host(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_host() - - end subroutine c_vect_set_host - - subroutine c_vect_set_dev(x) - implicit none - class(psb_c_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_dev() - - end subroutine c_vect_set_dev - - function c_vect_is_sync(x) result(res) - implicit none - logical :: res - class(psb_c_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_sync() - - end function c_vect_is_sync - - function c_vect_is_host(x) result(res) - implicit none - logical :: res - class(psb_c_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_host() - - end function c_vect_is_host - - function c_vect_is_dev(x) result(res) - implicit none - logical :: res - class(psb_c_vect_type), intent(inout) :: x - - res = .false. - if (allocated(x%v)) & - & res = x%v%is_dev() - - end function c_vect_is_dev - - - function c_vect_get_entry(x,index) result(res) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_spk_) :: res - res = czero - if (allocated(x%v)) res = x%v%get_entry(index) - end function c_vect_get_entry - - subroutine c_vect_set_entry(x,index,val) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_spk_) :: val - - if (allocated(x%v)) call x%v%set_entry(index,val) - end subroutine c_vect_set_entry - - function c_vect_dot_v(n,x,y) result(res) - implicit none - class(psb_c_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - complex(psb_spk_) :: res - - res = czero - if (allocated(x%v).and.allocated(y%v)) & - & res = x%v%dot(n,y%v) - - end function c_vect_dot_v - - function c_vect_dot_a(n,x,y) result(res) - implicit none - class(psb_c_vect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - complex(psb_spk_) :: res - - res = czero - if (allocated(x%v)) & - & res = x%v%dot_a(n,y) - - end function c_vect_dot_a - - subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call y%v%axpby(m,alpha,x%v,beta,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine c_vect_axpby_v - - subroutine c_vect_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - class(psb_c_vect_type), intent(inout) :: z - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call z%v%axpby(m,alpha,x%v,beta,y%v,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine c_vect_axpby_v2 - - subroutine c_vect_axpby_a(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - complex(psb_spk_), intent(in) :: x(:) - class(psb_c_vect_type), intent(inout) :: y - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(y%v)) & - & call y%v%axpby(m,alpha,x,beta,info) - - end subroutine c_vect_axpby_a - - subroutine c_vect_axpby_a2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - complex(psb_spk_), intent(in) :: x(:) - complex(psb_spk_), intent(in) :: y(:) - class(psb_c_vect_type), intent(inout) :: z - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - & call z%v%axpby(m,alpha,x,beta,y,info) - - end subroutine c_vect_axpby_a2 - - subroutine c_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - class(psb_c_vect_type), intent(inout) :: z - complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) - - end subroutine c_vect_upd_xyz - - subroutine c_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - class(psb_c_vect_type), intent(inout) :: z - class(psb_c_vect_type), intent(inout) :: w - complex(psb_spk_), intent (in) :: a, b, c, d, e, f - integer(psb_ipk_), intent(out) :: info - - if (allocated(w%v)) & - call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) - - end subroutine c_vect_xyzw - - - subroutine c_vect_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%mlt(x%v,info) - - end subroutine c_vect_mlt_v - - subroutine c_vect_mlt_a(x, y, info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: x(:) - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - - info = 0 - if (allocated(y%v)) & - & call y%v%mlt(x,info) - - end subroutine c_vect_mlt_a - - - subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: alpha,beta - complex(psb_spk_), intent(in) :: y(:) - complex(psb_spk_), intent(in) :: x(:) - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%mlt(alpha,x,y,beta,info) - - end subroutine c_vect_mlt_a_2 - - subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: alpha,beta - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.& - & allocated(z%v)) & - & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) - - end subroutine c_vect_mlt_v_2 - - subroutine c_vect_mlt_av(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: alpha,beta - complex(psb_spk_), intent(in) :: x(:) - class(psb_c_vect_type), intent(inout) :: y - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v).and.allocated(y%v)) & - & call z%v%mlt(alpha,x,y%v,beta,info) - - end subroutine c_vect_mlt_av - - subroutine c_vect_mlt_va(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: alpha,beta - complex(psb_spk_), intent(in) :: y(:) - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - - if (allocated(z%v).and.allocated(x%v)) & - & call z%v%mlt(alpha,x%v,y,beta,info) - - end subroutine c_vect_mlt_va - - subroutine c_vect_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info) - - end subroutine c_vect_div_v - - subroutine c_vect_div_v2( x, y, z, info) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info) - - end subroutine c_vect_div_v2 - - subroutine c_vect_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info,flag) - - end subroutine c_vect_div_v_check - - subroutine c_vect_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info,flag) - - end subroutine c_vect_div_v2_check - - subroutine c_vect_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: x(:) - complex(psb_spk_), intent(in) :: y(:) - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info) - - end subroutine c_vect_div_a2 - - subroutine c_vect_div_a2_check(x, y, z, info,flag) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: x(:) - complex(psb_spk_), intent(in) :: y(:) - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info,flag) - - end subroutine c_vect_div_a2_check - - subroutine c_vect_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info) - - end subroutine c_vect_inv_v - - subroutine c_vect_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info,flag) - - end subroutine c_vect_inv_v_check - - subroutine c_vect_inv_a2(x, y, info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(inout) :: x(:) - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info) - - end subroutine c_vect_inv_a2 - - subroutine c_vect_inv_a2_check(x, y, info,flag) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(inout) :: x(:) - class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info,flag) - - end subroutine c_vect_inv_a2_check - - subroutine c_vect_acmp_a2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: c - complex(psb_spk_), intent(inout) :: x(:) - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%acmp(x,c,info) - - end subroutine c_vect_acmp_a2 - - subroutine c_vect_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: c - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%acmp(x%v,c,info) - - end subroutine c_vect_acmp_v2 - - subroutine c_vect_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - complex(psb_spk_), intent (in) :: alpha - - if (allocated(x%v)) call x%v%scal(alpha) - - end subroutine c_vect_scal - - subroutine c_vect_absval1(x) - class(psb_c_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%absval() - - end subroutine c_vect_absval1 - - subroutine c_vect_absval2(x,y) - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: y - - if (allocated(x%v)) then - if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) - call x%v%absval(y%v) - end if - end subroutine c_vect_absval2 - - function c_vect_nrm2(n,x) result(res) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - if (allocated(x%v)) then - res = x%v%nrm2(n) - else - res = szero - end if - - end function c_vect_nrm2 - - function c_vect_nrm2_weight(n,x,w,aux) result(res) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: w - class(psb_c_vect_type), intent(inout), optional :: aux - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_) :: info - - ! Temp vectors - type(psb_c_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,cone,w%v%v,czero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -sone - return - end if - - if (allocated(x%v)) then - if (.not.present(aux)) then - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = szero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function c_vect_nrm2_weight - - function c_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) - use psi_serial_mod - implicit none - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: w - class(psb_c_vect_type), intent(inout) :: id - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_), intent(out) :: info - class(psb_c_vect_type), intent(inout), optional :: aux - - ! Temp vectors - type(psb_c_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,cone,w%v%v,czero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -sone - return - end if - - - if (allocated(x%v).and.allocated(id%v)) then - if (.not.present(aux)) then - where( abs(id%v%v) <= szero) wtemp%v%v = szero - call wtemp%set_host() - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - where( abs(id%v%v) <= szero) aux%v%v = szero - call aux%set_host() - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = szero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function c_vect_nrm2_weight_mask - - function c_vect_amax(n,x) result(res) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - if (allocated(x%v)) then - res = x%v%amax(n) - else - res = szero - end if - - end function c_vect_amax - - - function c_vect_asum(n,x) result(res) - implicit none - class(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - if (allocated(x%v)) then - res = x%v%asum(n) - else - res = szero - end if - - end function c_vect_asum - - - - subroutine c_vect_addconst_a2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: b - complex(psb_spk_), intent(inout) :: x(:) - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%addconst(x,b,info) - - end subroutine c_vect_addconst_a2 - - subroutine c_vect_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: b - class(psb_c_vect_type), intent(inout) :: x - class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%addconst(x%v,b,info) - - end subroutine c_vect_addconst_v2 - end module psb_c_vect_mod - module psb_c_multivect_mod use psb_c_base_multivect_mod @@ -1552,410 +1024,239 @@ module psb_c_multivect_mod class(psb_c_base_multivect_type), allocatable, target,& & save, private :: psb_c_base_multivect_default - interface psb_set_multivect_default - module procedure psb_c_set_multivect_default - end interface psb_set_multivect_default - - interface psb_get_multivect_default - module procedure psb_c_get_multivect_default - end interface psb_get_multivect_default - - -contains - - function c_mvect_get_dupl(x) result(res) - implicit none - class(psb_c_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function c_mvect_get_dupl - - subroutine c_mvect_set_dupl(x,val) - implicit none - class(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ - end if - end subroutine c_mvect_set_dupl - - - function c_mvect_is_remote_build(x) result(res) - implicit none - class(psb_c_multivect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function c_mvect_is_remote_build - - subroutine c_mvect_set_remote_build(x,val) - implicit none - class(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine c_mvect_set_remote_build - - - subroutine psb_c_set_multivect_default(v) - implicit none - class(psb_c_base_multivect_type), intent(in) :: v - - if (allocated(psb_c_base_multivect_default)) then - deallocate(psb_c_base_multivect_default) - end if - allocate(psb_c_base_multivect_default, mold=v) - - end subroutine psb_c_set_multivect_default - - function psb_c_get_multivect_default(v) result(res) - implicit none - class(psb_c_multivect_type), intent(in) :: v - class(psb_c_base_multivect_type), pointer :: res - - res => psb_c_get_base_multivect_default() - - end function psb_c_get_multivect_default - - - function psb_c_get_base_multivect_default() result(res) - implicit none - class(psb_c_base_multivect_type), pointer :: res - - if (.not.allocated(psb_c_base_multivect_default)) then - allocate(psb_c_base_multivect_type :: psb_c_base_multivect_default) - end if - - res => psb_c_base_multivect_default - - end function psb_c_get_base_multivect_default - - - subroutine c_mvect_clone(x,y,info) - implicit none - class(psb_c_multivect_type), intent(inout) :: x - class(psb_c_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - call y%bld_x(x%get_vect(),mold=x%v) - end if - end subroutine c_mvect_clone - - subroutine c_mvect_bld_x(x,invect,mold) - complex(psb_spk_), intent(in) :: invect(:,:) - class(psb_c_multivect_type), intent(out) :: x - class(psb_c_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - class(psb_c_base_multivect_type), pointer :: mld - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect) - - end subroutine c_mvect_bld_x - - - subroutine c_mvect_bld_n(x,m,n,mold,scratch) - integer(psb_ipk_), intent(in) :: m,n - class(psb_c_multivect_type), intent(out) :: x - class(psb_c_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) - endif - if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) - - end subroutine c_mvect_bld_n - - function c_mvect_get_vect(x) result(res) - class(psb_c_multivect_type), intent(inout) :: x - complex(psb_spk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - res = x%v%get_vect() - end if - end function c_mvect_get_vect - - subroutine c_mvect_set_scal(x,val) - class(psb_c_multivect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine c_mvect_set_scal - - subroutine c_mvect_set_vect(x,val) - class(psb_c_multivect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val(:,:) - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine c_mvect_set_vect - - - function constructor(x) result(this) - complex(psb_spk_) :: x(:,:) - type(psb_c_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_x(x) - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) - - end function constructor - - - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_c_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_n(m,n) - call this%asb(m,n,info) - - end function size_const - - function c_mvect_get_nrows(x) result(res) - implicit none - class(psb_c_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function c_mvect_get_nrows - - function c_mvect_get_ncols(x) result(res) - implicit none - class(psb_c_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_ncols() - end function c_mvect_get_ncols - - function c_mvect_sizeof(x) result(res) - implicit none - class(psb_c_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function c_mvect_sizeof - - function c_mvect_get_fmt(x) result(res) - implicit none - class(psb_c_multivect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function c_mvect_get_fmt - - subroutine c_mvect_all(m,n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_c_multivect_type), intent(out) :: x - class(psb_c_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_c_base_multivect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(m,n,info) - else - info = psb_err_alloc_dealloc_ - end if - - end subroutine c_mvect_all - - subroutine c_mvect_reall(m,n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(m,n,info) - if (info == 0) & - & call x%asb(m,n,info) - - end subroutine c_mvect_reall - - subroutine c_mvect_zero(x) - use psi_serial_mod - implicit none - class(psb_c_multivect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine c_mvect_zero - - subroutine c_mvect_asb(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) & - & call x%v%asb(m,n,info) - - end subroutine c_mvect_asb - - subroutine c_mvect_sync(x) - implicit none - class(psb_c_multivect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine c_mvect_sync - - subroutine c_mvect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: alpha, beta, y(:) - class(psb_c_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine c_mvect_gthab - - subroutine c_mvect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: y(:) - class(psb_c_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine c_mvect_gthzv - - subroutine c_mvect_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_spk_) :: y(:) - class(psb_c_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(i,n,idx,y) - - end subroutine c_mvect_gthzv_x - - subroutine c_mvect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: beta, x(:) - class(psb_c_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine c_mvect_sctb - - subroutine c_mvect_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_spk_) :: beta, x(:) - class(psb_c_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(i,n,idx,x,beta) - - end subroutine c_mvect_sctb_x - - subroutine c_mvect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine c_mvect_free - - subroutine c_mvect_ins(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine c_mvect_ins - - - subroutine c_mvect_cnv(x,mold) - class(psb_c_multivect_type), intent(inout) :: x - class(psb_c_base_multivect_type), intent(in), optional :: mold - class(psb_c_base_multivect_type), allocatable :: tmp - integer(psb_ipk_) :: info - - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info, mold=psb_c_get_base_multivect_default()) - endif - if (allocated(x%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%free(info) - end if - call move_alloc(tmp,x%v) - end subroutine c_mvect_cnv - - -!!$ function c_mvect_dot_v(n,x,y) result(res) + interface + module function c_mvect_get_dupl(x) result(res) + class(psb_c_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_mvect_get_dupl + end interface + + interface + module subroutine c_mvect_set_dupl(x,val) + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine c_mvect_set_dupl + end interface + + interface + module function c_mvect_is_remote_build(x) result(res) + class(psb_c_multivect_type), intent(in) :: x + logical :: res + end function c_mvect_is_remote_build + end interface + + interface + module subroutine c_mvect_set_remote_build(x,val) + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine c_mvect_set_remote_build + end interface + + interface + module subroutine psb_c_set_multivect_default(v) + class(psb_c_base_multivect_type), intent(in) :: v + end subroutine psb_c_set_multivect_default + end interface + + interface + module function psb_c_get_multivect_default(v) result(res) + class(psb_c_multivect_type), intent(in) :: v + class(psb_c_base_multivect_type), pointer :: res + end function psb_c_get_multivect_default + end interface + + interface + module function psb_c_get_base_multivect_default() result(res) + class(psb_c_base_multivect_type), pointer :: res + end function psb_c_get_base_multivect_default + end interface + + interface + module subroutine c_mvect_clone(x,y,info) + class(psb_c_multivect_type), intent(inout) :: x + class(psb_c_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_mvect_clone + end interface + + interface + module subroutine c_mvect_bld_x(x,invect,mold) + complex(psb_spk_), intent(in) :: invect(:,:) + class(psb_c_multivect_type), intent(out) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + end subroutine c_mvect_bld_x + end interface + + + interface + module subroutine c_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(out) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine c_mvect_bld_n + end interface + + interface + module function c_mvect_get_vect(x) result(res) + class(psb_c_multivect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:,:) + end function c_mvect_get_vect + end interface + + interface + module subroutine c_mvect_set_scal(x,val) + class(psb_c_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + end subroutine c_mvect_set_scal + end interface + + interface + module subroutine c_mvect_set_vect(x,val) + class(psb_c_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:,:) + end subroutine c_mvect_set_vect + end interface + + interface + module function c_mvect_get_nrows(x) result(res) + class(psb_c_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_mvect_get_nrows + end interface + + interface + module function c_mvect_get_ncols(x) result(res) + class(psb_c_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_mvect_get_ncols + end interface + + interface + module function c_mvect_sizeof(x) result(res) + class(psb_c_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function c_mvect_sizeof + end interface + + interface + module function c_mvect_get_fmt(x) result(res) + class(psb_c_multivect_type), intent(in) :: x + character(len=5) :: res + end function c_mvect_get_fmt + end interface + + interface + module subroutine c_mvect_all(m,n, x, info, mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(out) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + end subroutine c_mvect_all + end interface + + interface + module subroutine c_mvect_reall(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_mvect_reall + end interface + + interface + module subroutine c_mvect_zero(x) + class(psb_c_multivect_type), intent(inout) :: x + end subroutine c_mvect_zero + end interface + + interface + module subroutine c_mvect_asb(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_mvect_asb + end interface + + interface + module subroutine c_mvect_sync(x) + class(psb_c_multivect_type), intent(inout) :: x + end subroutine c_mvect_sync + end interface + + interface + module subroutine c_mvect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_multivect_type) :: x + end subroutine c_mvect_gthab + end interface + + interface + module subroutine c_mvect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_multivect_type) :: x + end subroutine c_mvect_gthzv + end interface + + interface + module subroutine c_mvect_gthzv_x(i,n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: y(:) + class(psb_c_multivect_type) :: x + end subroutine c_mvect_gthzv_x + end interface + + interface + module subroutine c_mvect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_multivect_type) :: y + end subroutine c_mvect_sctb + end interface + + interface + module subroutine c_mvect_sctb_x(i,n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta, x(:) + class(psb_c_multivect_type) :: y + end subroutine c_mvect_sctb_x + end interface + + interface + module subroutine c_mvect_free(x, info) + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_mvect_free + end interface + + interface + module subroutine c_mvect_ins(n,irl,val,x,maxr,info) + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine c_mvect_ins + end interface + + interface + module subroutine c_mvect_cnv(x,mold) + class(psb_c_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + end subroutine c_mvect_cnv + end interface + + +!!$ module function c_mvect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n @@ -1967,7 +1268,7 @@ contains !!$ !!$ end function c_mvect_dot_v !!$ -!!$ function c_mvect_dot_a(n,x,y) result(res) +!!$ module function c_mvect_dot_a(n,x,y) result(res) !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ complex(psb_spk_), intent(in) :: y(:) @@ -1980,7 +1281,7 @@ contains !!$ !!$ end function c_mvect_dot_a !!$ -!!$ subroutine c_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ module subroutine c_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -1997,7 +1298,7 @@ contains !!$ !!$ end subroutine c_mvect_axpby_v !!$ -!!$ subroutine c_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ module subroutine c_mvect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -2012,7 +1313,7 @@ contains !!$ end subroutine c_mvect_axpby_a !!$ !!$ -!!$ subroutine c_mvect_mlt_v(x, y, info) +!!$ module subroutine c_mvect_mlt_v(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x @@ -2026,7 +1327,7 @@ contains !!$ !!$ end subroutine c_mvect_mlt_v !!$ -!!$ subroutine c_mvect_mlt_a(x, y, info) +!!$ module subroutine c_mvect_mlt_a(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_spk_), intent(in) :: x(:) @@ -2042,7 +1343,7 @@ contains !!$ end subroutine c_mvect_mlt_a !!$ !!$ -!!$ subroutine c_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ module subroutine c_mvect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta @@ -2058,7 +1359,7 @@ contains !!$ !!$ end subroutine c_mvect_mlt_a_2 !!$ -!!$ subroutine c_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ module subroutine c_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta @@ -2076,8 +1377,8 @@ contains !!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) !!$ !!$ end subroutine c_mvect_mlt_v_2 -!!$ -!!$ subroutine c_mvect_mlt_av(alpha,x,y,beta,z,info) + +!!$ module subroutine c_mvect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta @@ -2093,7 +1394,7 @@ contains !!$ !!$ end subroutine c_mvect_mlt_av !!$ -!!$ subroutine c_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ module subroutine c_mvect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta @@ -2110,7 +1411,7 @@ contains !!$ !!$ end subroutine c_mvect_mlt_va !!$ -!!$ subroutine c_mvect_scal(alpha, x) +!!$ module subroutine c_mvect_scal(alpha, x) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x @@ -2121,7 +1422,7 @@ contains !!$ end subroutine c_mvect_scal !!$ !!$ -!!$ function c_mvect_nrm2(n,x) result(res) +!!$ module function c_mvect_nrm2(n,x) result(res) !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2135,7 +1436,7 @@ contains !!$ !!$ end function c_mvect_nrm2 !!$ -!!$ function c_mvect_amax(n,x) result(res) +!!$ module function c_mvect_amax(n,x) result(res) !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2149,7 +1450,7 @@ contains !!$ !!$ end function c_mvect_amax !!$ -!!$ function c_mvect_asum(n,x) result(res) +!!$ module function c_mvect_asum(n,x) result(res) !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2163,5 +1464,26 @@ contains !!$ !!$ end function c_mvect_asum -end module psb_c_multivect_mod +contains + + function constructor(x) result(this) + complex(psb_spk_) :: x(:,:) + type(psb_c_multivect_type) :: this + integer(psb_ipk_) :: info + call this%bld_x(x) + call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + + end function constructor + + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_c_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld_n(m,n) + call this%asb(m,n,info) + + end function size_const + +end module psb_c_multivect_mod diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 0fa7441d..63fedb3a 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -195,363 +195,785 @@ module psb_d_vect_mod class(psb_d_base_vect_type), allocatable, target,& & save, private :: psb_d_base_vect_default + + interface + module function d_vect_get_dupl(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_vect_get_dupl + end interface + + interface + module subroutine d_vect_set_dupl(x,val) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine d_vect_set_dupl + end interface + + interface + module function d_vect_get_ncfs(x) result(res) + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_vect_get_ncfs + end interface + + interface + module subroutine d_vect_set_ncfs(x,val) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine d_vect_set_ncfs + end interface + + interface + module function d_vect_get_state(x) result(res) + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_vect_get_state + end interface + + interface + module function d_vect_is_null(x) result(res) + class(psb_d_vect_type), intent(in) :: x + logical :: res + end function d_vect_is_null + end interface + + interface + module function d_vect_is_bld(x) result(res) + class(psb_d_vect_type), intent(in) :: x + logical :: res + end function d_vect_is_bld + end interface + + interface + module function d_vect_is_upd(x) result(res) + class(psb_d_vect_type), intent(in) :: x + logical :: res + end function d_vect_is_upd + end interface + + interface + module function d_vect_is_asb(x) result(res) + class(psb_d_vect_type), intent(in) :: x + logical :: res + end function d_vect_is_asb + end interface + + interface + module subroutine d_vect_set_state(n,x) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine d_vect_set_state + end interface + + interface + module subroutine d_vect_set_null(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_set_null + end interface + + interface + module subroutine d_vect_set_bld(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_set_bld + end interface + + interface + module subroutine d_vect_set_upd(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_set_upd + end interface + + interface + module subroutine d_vect_set_asb(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_set_asb + end interface + + interface + module function d_vect_get_nrmv(x) result(res) + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_vect_get_nrmv + end interface + + interface + module subroutine d_vect_set_nrmv(x,val) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine d_vect_set_nrmv + end interface + + interface + module function d_vect_is_remote_build(x) result(res) + class(psb_d_vect_type), intent(in) :: x + logical :: res + end function d_vect_is_remote_build + end interface + + interface + module subroutine d_vect_set_remote_build(x,val) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine d_vect_set_remote_build + end interface + interface psb_set_vect_default - module procedure psb_d_set_vect_default - end interface psb_set_vect_default + module subroutine psb_d_set_vect_default(v) + class(psb_d_base_vect_type), intent(in) :: v + end subroutine psb_d_set_vect_default + end interface interface psb_get_vect_default - module procedure psb_d_get_vect_default - end interface psb_get_vect_default - + module function psb_d_get_vect_default(v) result(res) + class(psb_d_vect_type), intent(in) :: v + class(psb_d_base_vect_type), pointer :: res + end function psb_d_get_vect_default + end interface + + interface + module subroutine psb_d_clear_vect_default() + end subroutine psb_d_clear_vect_default + end interface + + interface + module function psb_d_get_base_vect_default() result(res) + class(psb_d_base_vect_type), pointer :: res + end function psb_d_get_base_vect_default + end interface + + interface + module subroutine d_vect_clone(x,y,info) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_clone + end interface + + interface + module subroutine d_vect_bld_x(x,invect,mold,scratch) + real(psb_dpk_), intent(in) :: invect(:) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine d_vect_bld_x + end interface + + interface + module subroutine d_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine d_vect_bld_mn + end interface + + interface + module subroutine d_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine d_vect_bld_en + end interface + + interface + module function d_vect_get_vect(x,n) result(res) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function d_vect_get_vect + end interface + + interface + module subroutine d_vect_set_scal(x,val,first,last) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine d_vect_set_scal + end interface + + interface + module subroutine d_vect_set_vect(x,val,first,last) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine d_vect_set_vect + end interface + + interface + module subroutine d_vect_check_addr(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_check_addr + end interface + + interface + module function d_vect_get_nrows(x) result(res) + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_vect_get_nrows + end interface + + interface + module function d_vect_sizeof(x) result(res) + class(psb_d_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function d_vect_sizeof + end interface + + interface + module function d_vect_get_fmt(x) result(res) + class(psb_d_vect_type), intent(in) :: x + character(len=5) :: res + end function d_vect_get_fmt + end interface + + interface + module subroutine d_vect_all(n, x, info, mold) + 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 + end subroutine d_vect_all + end interface + + interface + module subroutine d_vect_reinit(x, info, clear) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine d_vect_reinit + end interface + + interface + module subroutine d_vect_reall(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_reall + end interface + + interface + module subroutine d_vect_zero(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_zero + end interface + + interface + module subroutine d_vect_asb(n, x, info, scratch) + integer(psb_ipk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine d_vect_asb + end interface + + interface + module subroutine d_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_vect_type) :: x + end subroutine d_vect_gthab + end interface + + interface + module subroutine d_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_vect_type) :: x + end subroutine d_vect_gthzv + end interface + + interface + module subroutine d_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_vect_type) :: y + end subroutine d_vect_sctb + end interface + + interface + module subroutine d_vect_free(x, info) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_free + end interface + + interface + module subroutine d_vect_ins_a(n,irl,val,x,maxr,info) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_ins_a + end interface + + interface + module subroutine d_vect_ins_v(n,irl,val,x,maxr,info) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_d_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_ins_v + end interface + + interface + module subroutine d_vect_cnv(x,mold) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + class(psb_d_base_vect_type), allocatable :: tmp + end subroutine d_vect_cnv + end interface + + interface + module subroutine d_vect_sync(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_sync + end interface + + interface + module subroutine d_vect_set_sync(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_set_sync + end interface + + interface + module subroutine d_vect_set_host(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_set_host + end interface + + interface + module subroutine d_vect_set_dev(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_set_dev + end interface + + interface + module function d_vect_is_sync(x) result(res) + logical :: res + class(psb_d_vect_type), intent(inout) :: x + end function d_vect_is_sync + end interface + + interface + module function d_vect_is_host(x) result(res) + logical :: res + class(psb_d_vect_type), intent(inout) :: x + end function d_vect_is_host + end interface + + interface + module function d_vect_is_dev(x) result(res) + logical :: res + class(psb_d_vect_type), intent(inout) :: x + end function d_vect_is_dev + end interface + + + interface + module function d_vect_get_entry(x,index) result(res) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: res + end function d_vect_get_entry + end interface + + interface + module subroutine d_vect_set_entry(x,index,val) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + end subroutine d_vect_set_entry + end interface + + interface + module function d_vect_dot_v(n,x,y) result(res) + class(psb_d_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_vect_dot_v + end interface + + interface + module function d_vect_dot_a(n,x,y) result(res) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_vect_dot_a + end interface + + interface + module subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_axpby_v + end interface + + interface + module subroutine d_vect_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_axpby_v2 + end interface + + interface + module subroutine d_vect_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_axpby_a + end interface + + interface + module subroutine d_vect_axpby_a2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_axpby_a2 + end interface + + interface + module subroutine d_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_upd_xyz + end interface + + interface + module subroutine d_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + class(psb_d_vect_type), intent(inout) :: w + real(psb_dpk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_xyzw + end interface + + interface + module subroutine d_vect_mlt_v(x, y, info) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_mlt_v + end interface + + interface + module subroutine d_vect_mlt_a(x, y, info) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_mlt_a + end interface + + interface + module subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: y(:) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_mlt_a_2 + end interface + + interface + module subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_dpk_), intent(in) :: alpha,beta + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine d_vect_mlt_v_2 + end interface + + interface + module subroutine d_vect_mlt_av(alpha,x,y,beta,z,info) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_mlt_av + end interface + + interface + module subroutine d_vect_mlt_va(alpha,x,y,beta,z,info) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_mlt_va + end interface + + interface + module subroutine d_vect_div_v(x, y, info) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_div_v + end interface + + interface + module subroutine d_vect_div_v2( x, y, z, info) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_div_v2 + end interface + + interface + module subroutine d_vect_div_v_check(x, y, info, flag) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_vect_div_v_check + end interface + + interface + module subroutine d_vect_div_v2_check(x, y, z, info, flag) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_vect_div_v2_check + end interface + + interface + module subroutine d_vect_div_a2(x, y, z, info) + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_div_a2 + end interface + + interface + module subroutine d_vect_div_a2_check(x, y, z, info,flag) + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_vect_div_a2_check + end interface + + interface + module subroutine d_vect_inv_v(x, y, info) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_inv_v + end interface + + interface + module subroutine d_vect_inv_v_check(x, y, info, flag) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_vect_inv_v_check + end interface + + interface + module subroutine d_vect_inv_a2(x, y, info) + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_inv_a2 + end interface + + interface + module subroutine d_vect_inv_a2_check(x, y, info,flag) + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_vect_inv_a2_check + end interface + + interface + module subroutine d_vect_acmp_a2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_acmp_a2 + end interface + + interface + module subroutine d_vect_acmp_v2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_acmp_v2 + end interface + + interface + module subroutine d_vect_scal(alpha, x) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent (in) :: alpha + end subroutine d_vect_scal + end interface + + interface + module subroutine d_vect_absval1(x) + class(psb_d_vect_type), intent(inout) :: x + end subroutine d_vect_absval1 + end interface + + interface + module subroutine d_vect_absval2(x,y) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + end subroutine d_vect_absval2 + end interface + + interface + module function d_vect_nrm2(n,x) result(res) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_vect_nrm2 + end interface + + interface + module function d_vect_nrm2_weight(n,x,w,aux) result(res) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: w + class(psb_d_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_vect_nrm2_weight + end interface + + interface + module function d_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: w + class(psb_d_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_d_vect_type), intent(inout), optional :: aux + end function d_vect_nrm2_weight_mask + end interface + + interface + module function d_vect_amax(n,x) result(res) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_vect_amax + end interface + + interface + module function d_vect_min(n,x) result(res) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_vect_min + end interface + + interface + module function d_vect_asum(n,x) result(res) + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_vect_asum + end interface + + + interface + module subroutine d_vect_mask_a(c,x,m,t,info) + real(psb_dpk_), intent(inout) :: c(:) + real(psb_dpk_), intent(inout) :: x(:) + logical, intent(out) :: t; + class(psb_d_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_mask_a + end interface + + interface + module subroutine d_vect_mask_v(c,x,m,t,info) + class(psb_d_vect_type), intent(inout) :: c + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: m + logical, intent(out) :: t; + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_mask_v + end interface + + interface + module function d_vect_minquotient_v(x, y, info) result(z) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + end function d_vect_minquotient_v + end interface + + interface + module function d_vect_minquotient_a2(x, y, info) result(z) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: z + end function d_vect_minquotient_a2 + end interface + + + + interface + module subroutine d_vect_addconst_a2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_addconst_a2 + end interface + + interface + module subroutine d_vect_addconst_v2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_vect_addconst_v2 + end interface contains - function d_vect_get_dupl(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_dupl() - else - res = psb_dupl_null_ - end if - end function d_vect_get_dupl - - subroutine d_vect_set_dupl(x,val) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_dupl(val) - else - call x%v%set_dupl(psb_dupl_def_) - end if - end if - end subroutine d_vect_set_dupl - - function d_vect_get_ncfs(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_ncfs() - else - res = 0 - end if - end function d_vect_get_ncfs - - subroutine d_vect_set_ncfs(x,val) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_ncfs(val) - else - call x%v%set_ncfs(0) - end if - end if - end subroutine d_vect_set_ncfs - - function d_vect_get_state(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_state() - else - res = psb_vect_null_ - end if - end function d_vect_get_state - - function d_vect_is_null(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_null_) - end function d_vect_is_null - - function d_vect_is_bld(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_bld_) - end function d_vect_is_bld - - function d_vect_is_upd(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_upd_) - end function d_vect_is_upd - - function d_vect_is_asb(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_asb_) - end function d_vect_is_asb - - subroutine d_vect_set_state(n,x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - if (allocated(x%v)) then - call x%v%set_state(n) - end if - end subroutine d_vect_set_state - - - subroutine d_vect_set_null(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_null_) - end subroutine d_vect_set_null - - subroutine d_vect_set_bld(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_bld_) - end subroutine d_vect_set_bld - - subroutine d_vect_set_upd(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_upd_) - end subroutine d_vect_set_upd - - subroutine d_vect_set_asb(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_asb_) - end subroutine d_vect_set_asb - - 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 - class(psb_d_vect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function d_vect_is_remote_build - - subroutine d_vect_set_remote_build(x,val) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine d_vect_set_remote_build - - subroutine psb_d_set_vect_default(v) - implicit none - class(psb_d_base_vect_type), intent(in) :: v - - if (allocated(psb_d_base_vect_default)) then - deallocate(psb_d_base_vect_default) - end if - allocate(psb_d_base_vect_default, mold=v) - - end subroutine psb_d_set_vect_default - - function psb_d_get_vect_default(v) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: v - class(psb_d_base_vect_type), pointer :: res - - res => psb_d_get_base_vect_default() - - end function psb_d_get_vect_default - - subroutine psb_d_clear_vect_default() - implicit none - - if (allocated(psb_d_base_vect_default)) then - deallocate(psb_d_base_vect_default) - end if - - end subroutine psb_d_clear_vect_default - - function psb_d_get_base_vect_default() result(res) - implicit none - class(psb_d_base_vect_type), pointer :: res - - if (.not.allocated(psb_d_base_vect_default)) then - allocate(psb_d_base_vect_type :: psb_d_base_vect_default) - end if - - res => psb_d_base_vect_default - - end function psb_d_get_base_vect_default - - subroutine d_vect_clone(x,y,info) - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - ! - ! Using sourced allocation here creates - ! problems with handling of memory allocated - ! elsewhere (e.g. accelerators), hence delegation - ! to %bld method - ! - call y%bld(x%get_vect(),mold=x%v) - end if - end subroutine d_vect_clone - - subroutine d_vect_bld_x(x,invect,mold,scratch) - real(psb_dpk_), intent(in) :: invect(:) - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) - - end subroutine d_vect_bld_x - - - subroutine d_vect_bld_mn(x,n,mold,scratch) - integer(psb_mpk_), intent(in) :: n - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - class(psb_d_base_vect_type), pointer :: mld - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine d_vect_bld_mn - - subroutine d_vect_bld_en(x,n,mold,scratch) - integer(psb_epk_), intent(in) :: n - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine d_vect_bld_en - - function d_vect_get_vect(x,n) result(res) - class(psb_d_vect_type), intent(inout) :: x - real(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - - if (allocated(x%v)) then - res = x%v%get_vect(n) - end if - end function d_vect_get_vect - - subroutine d_vect_set_scal(x,val,first,last) - class(psb_d_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine d_vect_set_scal - - subroutine d_vect_set_vect(x,val,first,last) - class(psb_d_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine d_vect_set_vect - - subroutine d_vect_check_addr(x) - class(psb_d_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%check_addr() - - end subroutine d_vect_check_addr - function constructor(x) result(this) real(psb_dpk_) :: x(:) type(psb_d_vect_type) :: this @@ -573,984 +995,8 @@ contains end function size_const - function d_vect_get_nrows(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function d_vect_get_nrows - - function d_vect_sizeof(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function d_vect_sizeof - - function d_vect_get_fmt(x) result(res) - implicit none - class(psb_d_vect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function d_vect_get_fmt - - 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 - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_d_base_vect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(n,info) - else - info = psb_err_alloc_dealloc_ - end if - call x%set_bld() - end subroutine d_vect_all - - subroutine d_vect_reinit(x, info, clear) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - - if (allocated(x%v)) call x%v%reinit(info,clear) - call x%set_upd() - - end subroutine d_vect_reinit - - subroutine d_vect_reall(n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(n,info) - if (info == 0) & - & call x%asb(n,info) - - end subroutine d_vect_reall - - subroutine d_vect_zero(x) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine d_vect_zero - - subroutine d_vect_asb(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - if (allocated(x%v)) then - call x%v%asb(n,info,scratch=scratch) - call x%set_asb() - end if - end subroutine d_vect_asb - - subroutine d_vect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: alpha, beta, y(:) - class(psb_d_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine d_vect_gthab - - subroutine d_vect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: y(:) - class(psb_d_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine d_vect_gthzv - - subroutine d_vect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: beta, x(:) - class(psb_d_vect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine d_vect_sctb - - subroutine d_vect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine d_vect_free - - subroutine d_vect_ins_a(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine d_vect_ins_a - - subroutine d_vect_ins_v(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - 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, 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,maxr,info) - - end subroutine d_vect_ins_v - - - subroutine d_vect_cnv(x,mold) - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(in), optional :: mold - class(psb_d_base_vect_type), allocatable :: tmp - - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info,mold=psb_d_get_base_vect_default()) - end if - if (allocated(x%v)) then - if (allocated(x%v%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%base_cpy(tmp) - call x%v%free(info) - endif - end if - call move_alloc(tmp,x%v) - - end subroutine d_vect_cnv - - - subroutine d_vect_sync(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine d_vect_sync - - subroutine d_vect_set_sync(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_sync() - - end subroutine d_vect_set_sync - - subroutine d_vect_set_host(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_host() - - end subroutine d_vect_set_host - - subroutine d_vect_set_dev(x) - implicit none - class(psb_d_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_dev() - - end subroutine d_vect_set_dev - - function d_vect_is_sync(x) result(res) - implicit none - logical :: res - class(psb_d_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_sync() - - end function d_vect_is_sync - - function d_vect_is_host(x) result(res) - implicit none - logical :: res - class(psb_d_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_host() - - end function d_vect_is_host - - function d_vect_is_dev(x) result(res) - implicit none - logical :: res - class(psb_d_vect_type), intent(inout) :: x - - res = .false. - if (allocated(x%v)) & - & res = x%v%is_dev() - - end function d_vect_is_dev - - - function d_vect_get_entry(x,index) result(res) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_dpk_) :: res - res = dzero - if (allocated(x%v)) res = x%v%get_entry(index) - end function d_vect_get_entry - - subroutine d_vect_set_entry(x,index,val) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_dpk_) :: val - - if (allocated(x%v)) call x%v%set_entry(index,val) - end subroutine d_vect_set_entry - - function d_vect_dot_v(n,x,y) result(res) - implicit none - class(psb_d_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - res = dzero - if (allocated(x%v).and.allocated(y%v)) & - & res = x%v%dot(n,y%v) - - end function d_vect_dot_v - - function d_vect_dot_a(n,x,y) result(res) - implicit none - class(psb_d_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - res = dzero - if (allocated(x%v)) & - & res = x%v%dot_a(n,y) - - end function d_vect_dot_a - - subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call y%v%axpby(m,alpha,x%v,beta,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine d_vect_axpby_v - - subroutine d_vect_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - class(psb_d_vect_type), intent(inout) :: z - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call z%v%axpby(m,alpha,x%v,beta,y%v,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine d_vect_axpby_v2 - - subroutine d_vect_axpby_a(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - real(psb_dpk_), intent(in) :: x(:) - class(psb_d_vect_type), intent(inout) :: y - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(y%v)) & - & call y%v%axpby(m,alpha,x,beta,info) - - end subroutine d_vect_axpby_a - - subroutine d_vect_axpby_a2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_), intent(in) :: y(:) - class(psb_d_vect_type), intent(inout) :: z - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - & call z%v%axpby(m,alpha,x,beta,y,info) - - end subroutine d_vect_axpby_a2 - - subroutine d_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - class(psb_d_vect_type), intent(inout) :: z - real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) - - end subroutine d_vect_upd_xyz - - subroutine d_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - class(psb_d_vect_type), intent(inout) :: z - class(psb_d_vect_type), intent(inout) :: w - real(psb_dpk_), intent (in) :: a, b, c, d, e, f - integer(psb_ipk_), intent(out) :: info - - if (allocated(w%v)) & - call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) - - end subroutine d_vect_xyzw - - - subroutine d_vect_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%mlt(x%v,info) - - end subroutine d_vect_mlt_v - - subroutine d_vect_mlt_a(x, y, info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: x(:) - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - - info = 0 - if (allocated(y%v)) & - & call y%v%mlt(x,info) - - end subroutine d_vect_mlt_a - - - subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: alpha,beta - real(psb_dpk_), intent(in) :: y(:) - real(psb_dpk_), intent(in) :: x(:) - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%mlt(alpha,x,y,beta,info) - - end subroutine d_vect_mlt_a_2 - - subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: alpha,beta - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.& - & allocated(z%v)) & - & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) - - end subroutine d_vect_mlt_v_2 - - subroutine d_vect_mlt_av(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: alpha,beta - real(psb_dpk_), intent(in) :: x(:) - class(psb_d_vect_type), intent(inout) :: y - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v).and.allocated(y%v)) & - & call z%v%mlt(alpha,x,y%v,beta,info) - - end subroutine d_vect_mlt_av - - subroutine d_vect_mlt_va(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: alpha,beta - real(psb_dpk_), intent(in) :: y(:) - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - - if (allocated(z%v).and.allocated(x%v)) & - & call z%v%mlt(alpha,x%v,y,beta,info) - - end subroutine d_vect_mlt_va - - subroutine d_vect_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info) - - end subroutine d_vect_div_v - - subroutine d_vect_div_v2( x, y, z, info) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info) - - end subroutine d_vect_div_v2 - - subroutine d_vect_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info,flag) - - end subroutine d_vect_div_v_check - - subroutine d_vect_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info,flag) - - end subroutine d_vect_div_v2_check - - subroutine d_vect_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_), intent(in) :: y(:) - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info) - - end subroutine d_vect_div_a2 - - subroutine d_vect_div_a2_check(x, y, z, info,flag) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_), intent(in) :: y(:) - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info,flag) - - end subroutine d_vect_div_a2_check - - subroutine d_vect_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info) - - end subroutine d_vect_inv_v - - subroutine d_vect_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info,flag) - - end subroutine d_vect_inv_v_check - - subroutine d_vect_inv_a2(x, y, info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(inout) :: x(:) - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info) - - end subroutine d_vect_inv_a2 - - subroutine d_vect_inv_a2_check(x, y, info,flag) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(inout) :: x(:) - class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info,flag) - - end subroutine d_vect_inv_a2_check - - subroutine d_vect_acmp_a2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: c - real(psb_dpk_), intent(inout) :: x(:) - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%acmp(x,c,info) - - end subroutine d_vect_acmp_a2 - - subroutine d_vect_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: c - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%acmp(x%v,c,info) - - end subroutine d_vect_acmp_v2 - - subroutine d_vect_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - real(psb_dpk_), intent (in) :: alpha - - if (allocated(x%v)) call x%v%scal(alpha) - - end subroutine d_vect_scal - - subroutine d_vect_absval1(x) - class(psb_d_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%absval() - - end subroutine d_vect_absval1 - - subroutine d_vect_absval2(x,y) - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - - if (allocated(x%v)) then - if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) - call x%v%absval(y%v) - end if - end subroutine d_vect_absval2 - - function d_vect_nrm2(n,x) result(res) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - if (allocated(x%v)) then - res = x%v%nrm2(n) - else - res = dzero - end if - - end function d_vect_nrm2 - - function d_vect_nrm2_weight(n,x,w,aux) result(res) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: w - class(psb_d_vect_type), intent(inout), optional :: aux - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_) :: info - - ! Temp vectors - type(psb_d_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,done,w%v%v,dzero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -done - return - end if - - if (allocated(x%v)) then - if (.not.present(aux)) then - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = dzero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function d_vect_nrm2_weight - - function d_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: w - class(psb_d_vect_type), intent(inout) :: id - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_), intent(out) :: info - class(psb_d_vect_type), intent(inout), optional :: aux - - ! Temp vectors - type(psb_d_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,done,w%v%v,dzero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -done - return - end if - - - if (allocated(x%v).and.allocated(id%v)) then - if (.not.present(aux)) then - where( abs(id%v%v) <= dzero) wtemp%v%v = dzero - call wtemp%set_host() - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - where( abs(id%v%v) <= dzero) aux%v%v = dzero - call aux%set_host() - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = dzero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function d_vect_nrm2_weight_mask - - function d_vect_amax(n,x) result(res) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - if (allocated(x%v)) then - res = x%v%amax(n) - else - res = dzero - end if - - end function d_vect_amax - - function d_vect_min(n,x) result(res) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - if (allocated(x%v)) then - res = x%v%minreal(n) - else - res = HUGE(dzero) - end if - - end function d_vect_min - - function d_vect_asum(n,x) result(res) - implicit none - class(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - if (allocated(x%v)) then - res = x%v%asum(n) - else - res = dzero - end if - - end function d_vect_asum - - - subroutine d_vect_mask_a(c,x,m,t,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(inout) :: c(:) - real(psb_dpk_), intent(inout) :: x(:) - logical, intent(out) :: t; - class(psb_d_vect_type), intent(inout) :: m - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(m%v)) & - & call m%mask(c,x,t,info) - - end subroutine d_vect_mask_a - - subroutine d_vect_mask_v(c,x,m,t,info) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: c - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: m - logical, intent(out) :: t; - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(c%v)) & - & call m%v%mask(x%v,c%v,t,info) - - end subroutine d_vect_mask_v - - function d_vect_minquotient_v(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: y - real(psb_dpk_) :: z - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & z = x%v%minquotient(y%v,info) - - end function d_vect_minquotient_v - - function d_vect_minquotient_a2(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_d_vect_type), intent(inout) :: x - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: z - - info = 0 - z = x%v%minquotient(y,info) - - end function d_vect_minquotient_a2 - - - - subroutine d_vect_addconst_a2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: b - real(psb_dpk_), intent(inout) :: x(:) - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%addconst(x,b,info) - - end subroutine d_vect_addconst_a2 - - subroutine d_vect_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: b - class(psb_d_vect_type), intent(inout) :: x - class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%addconst(x%v,b,info) - - end subroutine d_vect_addconst_v2 - end module psb_d_vect_mod - module psb_d_multivect_mod use psb_d_base_multivect_mod @@ -1631,410 +1077,239 @@ module psb_d_multivect_mod class(psb_d_base_multivect_type), allocatable, target,& & save, private :: psb_d_base_multivect_default - interface psb_set_multivect_default - module procedure psb_d_set_multivect_default - end interface psb_set_multivect_default - - interface psb_get_multivect_default - module procedure psb_d_get_multivect_default - end interface psb_get_multivect_default - - -contains - - function d_mvect_get_dupl(x) result(res) - implicit none - class(psb_d_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function d_mvect_get_dupl - - subroutine d_mvect_set_dupl(x,val) - implicit none - class(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ - end if - end subroutine d_mvect_set_dupl - - - function d_mvect_is_remote_build(x) result(res) - implicit none - class(psb_d_multivect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function d_mvect_is_remote_build - - subroutine d_mvect_set_remote_build(x,val) - implicit none - class(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine d_mvect_set_remote_build - - - subroutine psb_d_set_multivect_default(v) - implicit none - class(psb_d_base_multivect_type), intent(in) :: v - - if (allocated(psb_d_base_multivect_default)) then - deallocate(psb_d_base_multivect_default) - end if - allocate(psb_d_base_multivect_default, mold=v) - - end subroutine psb_d_set_multivect_default - - function psb_d_get_multivect_default(v) result(res) - implicit none - class(psb_d_multivect_type), intent(in) :: v - class(psb_d_base_multivect_type), pointer :: res - - res => psb_d_get_base_multivect_default() - - end function psb_d_get_multivect_default - - - function psb_d_get_base_multivect_default() result(res) - implicit none - class(psb_d_base_multivect_type), pointer :: res - - if (.not.allocated(psb_d_base_multivect_default)) then - allocate(psb_d_base_multivect_type :: psb_d_base_multivect_default) - end if - - res => psb_d_base_multivect_default - - end function psb_d_get_base_multivect_default - - - subroutine d_mvect_clone(x,y,info) - implicit none - class(psb_d_multivect_type), intent(inout) :: x - class(psb_d_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - call y%bld_x(x%get_vect(),mold=x%v) - end if - end subroutine d_mvect_clone - - subroutine d_mvect_bld_x(x,invect,mold) - real(psb_dpk_), intent(in) :: invect(:,:) - class(psb_d_multivect_type), intent(out) :: x - class(psb_d_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - class(psb_d_base_multivect_type), pointer :: mld - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect) - - end subroutine d_mvect_bld_x - - - subroutine d_mvect_bld_n(x,m,n,mold,scratch) - integer(psb_ipk_), intent(in) :: m,n - class(psb_d_multivect_type), intent(out) :: x - class(psb_d_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) - endif - if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) - - end subroutine d_mvect_bld_n - - function d_mvect_get_vect(x) result(res) - class(psb_d_multivect_type), intent(inout) :: x - real(psb_dpk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - res = x%v%get_vect() - end if - end function d_mvect_get_vect - - subroutine d_mvect_set_scal(x,val) - class(psb_d_multivect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine d_mvect_set_scal - - subroutine d_mvect_set_vect(x,val) - class(psb_d_multivect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val(:,:) - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine d_mvect_set_vect - - - function constructor(x) result(this) - real(psb_dpk_) :: x(:,:) - type(psb_d_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_x(x) - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) - - end function constructor - - - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_d_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_n(m,n) - call this%asb(m,n,info) - - end function size_const - - function d_mvect_get_nrows(x) result(res) - implicit none - class(psb_d_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function d_mvect_get_nrows - - function d_mvect_get_ncols(x) result(res) - implicit none - class(psb_d_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_ncols() - end function d_mvect_get_ncols - - function d_mvect_sizeof(x) result(res) - implicit none - class(psb_d_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function d_mvect_sizeof - - function d_mvect_get_fmt(x) result(res) - implicit none - class(psb_d_multivect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function d_mvect_get_fmt - - subroutine d_mvect_all(m,n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_d_multivect_type), intent(out) :: x - class(psb_d_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_d_base_multivect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(m,n,info) - else - info = psb_err_alloc_dealloc_ - end if - - end subroutine d_mvect_all - - subroutine d_mvect_reall(m,n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(m,n,info) - if (info == 0) & - & call x%asb(m,n,info) - - end subroutine d_mvect_reall - - subroutine d_mvect_zero(x) - use psi_serial_mod - implicit none - class(psb_d_multivect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine d_mvect_zero - - subroutine d_mvect_asb(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) & - & call x%v%asb(m,n,info) - - end subroutine d_mvect_asb - - subroutine d_mvect_sync(x) - implicit none - class(psb_d_multivect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine d_mvect_sync - - subroutine d_mvect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: alpha, beta, y(:) - class(psb_d_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine d_mvect_gthab - - subroutine d_mvect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: y(:) - class(psb_d_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine d_mvect_gthzv - - subroutine d_mvect_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_dpk_) :: y(:) - class(psb_d_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(i,n,idx,y) - - end subroutine d_mvect_gthzv_x - - subroutine d_mvect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: beta, x(:) - class(psb_d_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine d_mvect_sctb - - subroutine d_mvect_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_dpk_) :: beta, x(:) - class(psb_d_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(i,n,idx,x,beta) - - end subroutine d_mvect_sctb_x - - subroutine d_mvect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine d_mvect_free - - subroutine d_mvect_ins(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine d_mvect_ins - - - subroutine d_mvect_cnv(x,mold) - class(psb_d_multivect_type), intent(inout) :: x - class(psb_d_base_multivect_type), intent(in), optional :: mold - class(psb_d_base_multivect_type), allocatable :: tmp - integer(psb_ipk_) :: info - - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info, mold=psb_d_get_base_multivect_default()) - endif - if (allocated(x%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%free(info) - end if - call move_alloc(tmp,x%v) - end subroutine d_mvect_cnv - - -!!$ function d_mvect_dot_v(n,x,y) result(res) + interface + module function d_mvect_get_dupl(x) result(res) + class(psb_d_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_mvect_get_dupl + end interface + + interface + module subroutine d_mvect_set_dupl(x,val) + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine d_mvect_set_dupl + end interface + + interface + module function d_mvect_is_remote_build(x) result(res) + class(psb_d_multivect_type), intent(in) :: x + logical :: res + end function d_mvect_is_remote_build + end interface + + interface + module subroutine d_mvect_set_remote_build(x,val) + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine d_mvect_set_remote_build + end interface + + interface + module subroutine psb_d_set_multivect_default(v) + class(psb_d_base_multivect_type), intent(in) :: v + end subroutine psb_d_set_multivect_default + end interface + + interface + module function psb_d_get_multivect_default(v) result(res) + class(psb_d_multivect_type), intent(in) :: v + class(psb_d_base_multivect_type), pointer :: res + end function psb_d_get_multivect_default + end interface + + interface + module function psb_d_get_base_multivect_default() result(res) + class(psb_d_base_multivect_type), pointer :: res + end function psb_d_get_base_multivect_default + end interface + + interface + module subroutine d_mvect_clone(x,y,info) + class(psb_d_multivect_type), intent(inout) :: x + class(psb_d_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_mvect_clone + end interface + + interface + module subroutine d_mvect_bld_x(x,invect,mold) + real(psb_dpk_), intent(in) :: invect(:,:) + class(psb_d_multivect_type), intent(out) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + end subroutine d_mvect_bld_x + end interface + + + interface + module subroutine d_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(out) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine d_mvect_bld_n + end interface + + interface + module function d_mvect_get_vect(x) result(res) + class(psb_d_multivect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:,:) + end function d_mvect_get_vect + end interface + + interface + module subroutine d_mvect_set_scal(x,val) + class(psb_d_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + end subroutine d_mvect_set_scal + end interface + + interface + module subroutine d_mvect_set_vect(x,val) + class(psb_d_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:,:) + end subroutine d_mvect_set_vect + end interface + + interface + module function d_mvect_get_nrows(x) result(res) + class(psb_d_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_mvect_get_nrows + end interface + + interface + module function d_mvect_get_ncols(x) result(res) + class(psb_d_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_mvect_get_ncols + end interface + + interface + module function d_mvect_sizeof(x) result(res) + class(psb_d_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function d_mvect_sizeof + end interface + + interface + module function d_mvect_get_fmt(x) result(res) + class(psb_d_multivect_type), intent(in) :: x + character(len=5) :: res + end function d_mvect_get_fmt + end interface + + interface + module subroutine d_mvect_all(m,n, x, info, mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(out) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + end subroutine d_mvect_all + end interface + + interface + module subroutine d_mvect_reall(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_mvect_reall + end interface + + interface + module subroutine d_mvect_zero(x) + class(psb_d_multivect_type), intent(inout) :: x + end subroutine d_mvect_zero + end interface + + interface + module subroutine d_mvect_asb(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_mvect_asb + end interface + + interface + module subroutine d_mvect_sync(x) + class(psb_d_multivect_type), intent(inout) :: x + end subroutine d_mvect_sync + end interface + + interface + module subroutine d_mvect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_multivect_type) :: x + end subroutine d_mvect_gthab + end interface + + interface + module subroutine d_mvect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_multivect_type) :: x + end subroutine d_mvect_gthzv + end interface + + interface + module subroutine d_mvect_gthzv_x(i,n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: y(:) + class(psb_d_multivect_type) :: x + end subroutine d_mvect_gthzv_x + end interface + + interface + module subroutine d_mvect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_multivect_type) :: y + end subroutine d_mvect_sctb + end interface + + interface + module subroutine d_mvect_sctb_x(i,n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta, x(:) + class(psb_d_multivect_type) :: y + end subroutine d_mvect_sctb_x + end interface + + interface + module subroutine d_mvect_free(x, info) + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_mvect_free + end interface + + interface + module subroutine d_mvect_ins(n,irl,val,x,maxr,info) + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine d_mvect_ins + end interface + + interface + module subroutine d_mvect_cnv(x,mold) + class(psb_d_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + end subroutine d_mvect_cnv + end interface + + +!!$ module function d_mvect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n @@ -2046,7 +1321,7 @@ contains !!$ !!$ end function d_mvect_dot_v !!$ -!!$ function d_mvect_dot_a(n,x,y) result(res) +!!$ module function d_mvect_dot_a(n,x,y) result(res) !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ real(psb_dpk_), intent(in) :: y(:) @@ -2059,7 +1334,7 @@ contains !!$ !!$ end function d_mvect_dot_a !!$ -!!$ subroutine d_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ module subroutine d_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -2076,7 +1351,7 @@ contains !!$ !!$ end subroutine d_mvect_axpby_v !!$ -!!$ subroutine d_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ module subroutine d_mvect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -2091,7 +1366,7 @@ contains !!$ end subroutine d_mvect_axpby_a !!$ !!$ -!!$ subroutine d_mvect_mlt_v(x, y, info) +!!$ module subroutine d_mvect_mlt_v(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x @@ -2105,7 +1380,7 @@ contains !!$ !!$ end subroutine d_mvect_mlt_v !!$ -!!$ subroutine d_mvect_mlt_a(x, y, info) +!!$ module subroutine d_mvect_mlt_a(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_dpk_), intent(in) :: x(:) @@ -2121,7 +1396,7 @@ contains !!$ end subroutine d_mvect_mlt_a !!$ !!$ -!!$ subroutine d_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ module subroutine d_mvect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta @@ -2137,7 +1412,7 @@ contains !!$ !!$ end subroutine d_mvect_mlt_a_2 !!$ -!!$ subroutine d_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ module subroutine d_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta @@ -2155,8 +1430,8 @@ contains !!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) !!$ !!$ end subroutine d_mvect_mlt_v_2 -!!$ -!!$ subroutine d_mvect_mlt_av(alpha,x,y,beta,z,info) + +!!$ module subroutine d_mvect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta @@ -2172,7 +1447,7 @@ contains !!$ !!$ end subroutine d_mvect_mlt_av !!$ -!!$ subroutine d_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ module subroutine d_mvect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta @@ -2189,7 +1464,7 @@ contains !!$ !!$ end subroutine d_mvect_mlt_va !!$ -!!$ subroutine d_mvect_scal(alpha, x) +!!$ module subroutine d_mvect_scal(alpha, x) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x @@ -2200,7 +1475,7 @@ contains !!$ end subroutine d_mvect_scal !!$ !!$ -!!$ function d_mvect_nrm2(n,x) result(res) +!!$ module function d_mvect_nrm2(n,x) result(res) !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2214,7 +1489,7 @@ contains !!$ !!$ end function d_mvect_nrm2 !!$ -!!$ function d_mvect_amax(n,x) result(res) +!!$ module function d_mvect_amax(n,x) result(res) !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2228,7 +1503,7 @@ contains !!$ !!$ end function d_mvect_amax !!$ -!!$ function d_mvect_asum(n,x) result(res) +!!$ module function d_mvect_asum(n,x) result(res) !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2242,5 +1517,26 @@ contains !!$ !!$ end function d_mvect_asum -end module psb_d_multivect_mod +contains + + function constructor(x) result(this) + real(psb_dpk_) :: x(:,:) + type(psb_d_multivect_type) :: this + integer(psb_ipk_) :: info + call this%bld_x(x) + call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + + end function constructor + + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_d_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld_n(m,n) + call this%asb(m,n,info) + + end function size_const + +end module psb_d_multivect_mod diff --git a/base/modules/serial/psb_i2_vect_mod.F90 b/base/modules/serial/psb_i2_vect_mod.F90 index 136d9329..25b94ccb 100644 --- a/base/modules/serial/psb_i2_vect_mod.F90 +++ b/base/modules/serial/psb_i2_vect_mod.F90 @@ -133,362 +133,391 @@ module psb_i2_vect_mod class(psb_i2_base_vect_type), allocatable, target,& & save, private :: psb_i2_base_vect_default + + interface + module function i2_vect_get_dupl(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_vect_get_dupl + end interface + + interface + module subroutine i2_vect_set_dupl(x,val) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i2_vect_set_dupl + end interface + + interface + module function i2_vect_get_ncfs(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_vect_get_ncfs + end interface + + interface + module subroutine i2_vect_set_ncfs(x,val) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i2_vect_set_ncfs + end interface + + interface + module function i2_vect_get_state(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_vect_get_state + end interface + + interface + module function i2_vect_is_null(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + logical :: res + end function i2_vect_is_null + end interface + + interface + module function i2_vect_is_bld(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + logical :: res + end function i2_vect_is_bld + end interface + + interface + module function i2_vect_is_upd(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + logical :: res + end function i2_vect_is_upd + end interface + + interface + module function i2_vect_is_asb(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + logical :: res + end function i2_vect_is_asb + end interface + + interface + module subroutine i2_vect_set_state(n,x) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i2_vect_set_state + end interface + + interface + module subroutine i2_vect_set_null(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_set_null + end interface + + interface + module subroutine i2_vect_set_bld(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_set_bld + end interface + + interface + module subroutine i2_vect_set_upd(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_set_upd + end interface + + interface + module subroutine i2_vect_set_asb(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_set_asb + end interface + + interface + module function i2_vect_get_nrmv(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_vect_get_nrmv + end interface + + interface + module subroutine i2_vect_set_nrmv(x,val) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine i2_vect_set_nrmv + end interface + + interface + module function i2_vect_is_remote_build(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + logical :: res + end function i2_vect_is_remote_build + end interface + + interface + module subroutine i2_vect_set_remote_build(x,val) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i2_vect_set_remote_build + end interface + interface psb_set_vect_default - module procedure psb_i2_set_vect_default - end interface psb_set_vect_default + module subroutine psb_i2_set_vect_default(v) + class(psb_i2_base_vect_type), intent(in) :: v + end subroutine psb_i2_set_vect_default + end interface interface psb_get_vect_default - module procedure psb_i2_get_vect_default - end interface psb_get_vect_default - - -contains - - function i2_vect_get_dupl(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_dupl() - else - res = psb_dupl_null_ - end if - end function i2_vect_get_dupl - - subroutine i2_vect_set_dupl(x,val) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_dupl(val) - else - call x%v%set_dupl(psb_dupl_def_) - end if - end if - end subroutine i2_vect_set_dupl - - function i2_vect_get_ncfs(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_ncfs() - else - res = 0 - end if - end function i2_vect_get_ncfs - - subroutine i2_vect_set_ncfs(x,val) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_ncfs(val) - else - call x%v%set_ncfs(0) - end if - end if - end subroutine i2_vect_set_ncfs - - function i2_vect_get_state(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_state() - else - res = psb_vect_null_ - end if - end function i2_vect_get_state - - function i2_vect_is_null(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_null_) - end function i2_vect_is_null - - function i2_vect_is_bld(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_bld_) - end function i2_vect_is_bld - - function i2_vect_is_upd(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_upd_) - end function i2_vect_is_upd - - function i2_vect_is_asb(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_asb_) - end function i2_vect_is_asb - - subroutine i2_vect_set_state(n,x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - if (allocated(x%v)) then - call x%v%set_state(n) - end if - end subroutine i2_vect_set_state - - - subroutine i2_vect_set_null(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_null_) - end subroutine i2_vect_set_null - - subroutine i2_vect_set_bld(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_bld_) - end subroutine i2_vect_set_bld - - subroutine i2_vect_set_upd(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_upd_) - end subroutine i2_vect_set_upd - - subroutine i2_vect_set_asb(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_asb_) - end subroutine i2_vect_set_asb - - function i2_vect_get_nrmv(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%nrmv - end function i2_vect_get_nrmv - - subroutine i2_vect_set_nrmv(x,val) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val - - x%nrmv = val - end subroutine i2_vect_set_nrmv - - function i2_vect_is_remote_build(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function i2_vect_is_remote_build - - subroutine i2_vect_set_remote_build(x,val) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine i2_vect_set_remote_build - - subroutine psb_i2_set_vect_default(v) - implicit none - class(psb_i2_base_vect_type), intent(in) :: v - - if (allocated(psb_i2_base_vect_default)) then - deallocate(psb_i2_base_vect_default) - end if - allocate(psb_i2_base_vect_default, mold=v) - - end subroutine psb_i2_set_vect_default - - function psb_i2_get_vect_default(v) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: v - class(psb_i2_base_vect_type), pointer :: res - - res => psb_i2_get_base_vect_default() - - end function psb_i2_get_vect_default - - subroutine psb_i2_clear_vect_default() - implicit none - - if (allocated(psb_i2_base_vect_default)) then - deallocate(psb_i2_base_vect_default) - end if - - end subroutine psb_i2_clear_vect_default - - function psb_i2_get_base_vect_default() result(res) - implicit none - class(psb_i2_base_vect_type), pointer :: res - - if (.not.allocated(psb_i2_base_vect_default)) then - allocate(psb_i2_base_vect_type :: psb_i2_base_vect_default) - end if - - res => psb_i2_base_vect_default - - end function psb_i2_get_base_vect_default - - subroutine i2_vect_clone(x,y,info) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - class(psb_i2_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - ! - ! Using sourced allocation here creates - ! problems with handling of memory allocated - ! elsewhere (e.g. accelerators), hence delegation - ! to %bld method - ! - call y%bld(x%get_vect(),mold=x%v) - end if - end subroutine i2_vect_clone - - subroutine i2_vect_bld_x(x,invect,mold,scratch) - integer(psb_i2pk_), intent(in) :: invect(:) - class(psb_i2_vect_type), intent(inout) :: x - class(psb_i2_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i2_get_base_vect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) - - end subroutine i2_vect_bld_x - - - subroutine i2_vect_bld_mn(x,n,mold,scratch) - integer(psb_mpk_), intent(in) :: n - class(psb_i2_vect_type), intent(inout) :: x - class(psb_i2_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - class(psb_i2_base_vect_type), pointer :: mld - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i2_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine i2_vect_bld_mn - - subroutine i2_vect_bld_en(x,n,mold,scratch) - integer(psb_epk_), intent(in) :: n - class(psb_i2_vect_type), intent(inout) :: x - class(psb_i2_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i2_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine i2_vect_bld_en - - function i2_vect_get_vect(x,n) result(res) - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_i2pk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - - if (allocated(x%v)) then - res = x%v%get_vect(n) - end if - end function i2_vect_get_vect - - subroutine i2_vect_set_scal(x,val,first,last) - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine i2_vect_set_scal - - subroutine i2_vect_set_vect(x,val,first,last) - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) + module function psb_i2_get_vect_default(v) result(res) + class(psb_i2_vect_type), intent(in) :: v + class(psb_i2_base_vect_type), pointer :: res + end function psb_i2_get_vect_default + end interface + + interface + module subroutine psb_i2_clear_vect_default() + end subroutine psb_i2_clear_vect_default + end interface + + interface + module function psb_i2_get_base_vect_default() result(res) + class(psb_i2_base_vect_type), pointer :: res + end function psb_i2_get_base_vect_default + end interface + + interface + module subroutine i2_vect_clone(x,y,info) + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i2_vect_clone + end interface + + interface + module subroutine i2_vect_bld_x(x,invect,mold,scratch) + integer(psb_i2pk_), intent(in) :: invect(:) + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i2_vect_bld_x + end interface + + interface + module subroutine i2_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i2_vect_bld_mn + end interface + + interface + module subroutine i2_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i2_vect_bld_en + end interface + + interface + module function i2_vect_get_vect(x,n) result(res) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function i2_vect_get_vect + end interface + + interface + module subroutine i2_vect_set_scal(x,val,first,last) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine i2_vect_set_scal + end interface + + interface + module subroutine i2_vect_set_vect(x,val,first,last) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine i2_vect_set_vect + end interface + + interface + module subroutine i2_vect_check_addr(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_check_addr + end interface + + interface + module function i2_vect_get_nrows(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_vect_get_nrows + end interface + + interface + module function i2_vect_sizeof(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i2_vect_sizeof + end interface + + interface + module function i2_vect_get_fmt(x) result(res) + class(psb_i2_vect_type), intent(in) :: x + character(len=5) :: res + end function i2_vect_get_fmt + end interface + + interface + module subroutine i2_vect_all(n, x, info, mold) + integer(psb_ipk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_i2_base_vect_type), intent(in), optional :: mold + end subroutine i2_vect_all + end interface + + interface + module subroutine i2_vect_reinit(x, info, clear) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine i2_vect_reinit + end interface + + interface + module subroutine i2_vect_reall(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_vect_reall + end interface + + interface + module subroutine i2_vect_zero(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_zero + end interface + + interface + module subroutine i2_vect_asb(n, x, info, scratch) + integer(psb_ipk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine i2_vect_asb + end interface + + interface + module subroutine i2_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_vect_type) :: x + end subroutine i2_vect_gthab + end interface + + interface + module subroutine i2_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_vect_type) :: x + end subroutine i2_vect_gthzv + end interface + + interface + module subroutine i2_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_vect_type) :: y + end subroutine i2_vect_sctb + end interface + + interface + module subroutine i2_vect_free(x, info) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_vect_free + end interface + + interface + module subroutine i2_vect_ins_a(n,irl,val,x,maxr,info) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine i2_vect_ins_a + end interface + + interface + module subroutine i2_vect_ins_v(n,irl,val,x,maxr,info) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_i2_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine i2_vect_ins_v + end interface + + interface + module subroutine i2_vect_cnv(x,mold) + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + class(psb_i2_base_vect_type), allocatable :: tmp + end subroutine i2_vect_cnv + end interface + + interface + module subroutine i2_vect_sync(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_sync + end interface + + interface + module subroutine i2_vect_set_sync(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_set_sync + end interface + + interface + module subroutine i2_vect_set_host(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_set_host + end interface + + interface + module subroutine i2_vect_set_dev(x) + class(psb_i2_vect_type), intent(inout) :: x + end subroutine i2_vect_set_dev + end interface + + interface + module function i2_vect_is_sync(x) result(res) + logical :: res + class(psb_i2_vect_type), intent(inout) :: x + end function i2_vect_is_sync + end interface + + interface + module function i2_vect_is_host(x) result(res) + logical :: res + class(psb_i2_vect_type), intent(inout) :: x + end function i2_vect_is_host + end interface + + interface + module function i2_vect_is_dev(x) result(res) + logical :: res + class(psb_i2_vect_type), intent(inout) :: x + end function i2_vect_is_dev + end interface - end subroutine i2_vect_set_vect - subroutine i2_vect_check_addr(x) - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%check_addr() - end subroutine i2_vect_check_addr +contains function constructor(x) result(this) integer(psb_i2pk_) :: x(:) @@ -511,299 +540,8 @@ contains end function size_const - function i2_vect_get_nrows(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function i2_vect_get_nrows - - function i2_vect_sizeof(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function i2_vect_sizeof - - function i2_vect_get_fmt(x) result(res) - implicit none - class(psb_i2_vect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function i2_vect_get_fmt - - subroutine i2_vect_all(n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - class(psb_i2_base_vect_type), intent(in), optional :: mold - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_i2_base_vect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(n,info) - else - info = psb_err_alloc_dealloc_ - end if - call x%set_bld() - end subroutine i2_vect_all - - subroutine i2_vect_reinit(x, info, clear) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - - if (allocated(x%v)) call x%v%reinit(info,clear) - call x%set_upd() - - end subroutine i2_vect_reinit - - subroutine i2_vect_reall(n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(n,info) - if (info == 0) & - & call x%asb(n,info) - - end subroutine i2_vect_reall - - subroutine i2_vect_zero(x) - use psi_serial_mod - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine i2_vect_zero - - subroutine i2_vect_asb(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - if (allocated(x%v)) then - call x%v%asb(n,info,scratch=scratch) - call x%set_asb() - end if - end subroutine i2_vect_asb - - subroutine i2_vect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: alpha, beta, y(:) - class(psb_i2_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine i2_vect_gthab - - subroutine i2_vect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: y(:) - class(psb_i2_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine i2_vect_gthzv - - subroutine i2_vect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: beta, x(:) - class(psb_i2_vect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine i2_vect_sctb - - subroutine i2_vect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine i2_vect_free - - subroutine i2_vect_ins_a(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_i2pk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine i2_vect_ins_a - - subroutine i2_vect_ins_v(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i2_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - class(psb_i_vect_type), intent(inout) :: irl - class(psb_i2_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine i2_vect_ins_v - - - subroutine i2_vect_cnv(x,mold) - class(psb_i2_vect_type), intent(inout) :: x - class(psb_i2_base_vect_type), intent(in), optional :: mold - class(psb_i2_base_vect_type), allocatable :: tmp - - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info,mold=psb_i2_get_base_vect_default()) - end if - if (allocated(x%v)) then - if (allocated(x%v%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%base_cpy(tmp) - call x%v%free(info) - endif - end if - call move_alloc(tmp,x%v) - - end subroutine i2_vect_cnv - - - subroutine i2_vect_sync(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine i2_vect_sync - - subroutine i2_vect_set_sync(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_sync() - - end subroutine i2_vect_set_sync - - subroutine i2_vect_set_host(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_host() - - end subroutine i2_vect_set_host - - subroutine i2_vect_set_dev(x) - implicit none - class(psb_i2_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_dev() - - end subroutine i2_vect_set_dev - - function i2_vect_is_sync(x) result(res) - implicit none - logical :: res - class(psb_i2_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_sync() - - end function i2_vect_is_sync - - function i2_vect_is_host(x) result(res) - implicit none - logical :: res - class(psb_i2_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_host() - - end function i2_vect_is_host - - function i2_vect_is_dev(x) result(res) - implicit none - logical :: res - class(psb_i2_vect_type), intent(inout) :: x - - res = .false. - if (allocated(x%v)) & - & res = x%v%is_dev() - - end function i2_vect_is_dev - - - - end module psb_i2_vect_mod - module psb_i2_multivect_mod use psb_i2_base_multivect_mod @@ -866,171 +604,241 @@ module psb_i2_multivect_mod class(psb_i2_base_multivect_type), allocatable, target,& & save, private :: psb_i2_base_multivect_default - interface psb_set_multivect_default - module procedure psb_i2_set_multivect_default - end interface psb_set_multivect_default - - interface psb_get_multivect_default - module procedure psb_i2_get_multivect_default - end interface psb_get_multivect_default + + interface + module function i2_mvect_get_dupl(x) result(res) + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_mvect_get_dupl + end interface + + interface + module subroutine i2_mvect_set_dupl(x,val) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i2_mvect_set_dupl + end interface + + interface + module function i2_mvect_is_remote_build(x) result(res) + class(psb_i2_multivect_type), intent(in) :: x + logical :: res + end function i2_mvect_is_remote_build + end interface + + interface + module subroutine i2_mvect_set_remote_build(x,val) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i2_mvect_set_remote_build + end interface + + interface + module subroutine psb_i2_set_multivect_default(v) + class(psb_i2_base_multivect_type), intent(in) :: v + end subroutine psb_i2_set_multivect_default + end interface + + interface + module function psb_i2_get_multivect_default(v) result(res) + class(psb_i2_multivect_type), intent(in) :: v + class(psb_i2_base_multivect_type), pointer :: res + end function psb_i2_get_multivect_default + end interface + + interface + module function psb_i2_get_base_multivect_default() result(res) + class(psb_i2_base_multivect_type), pointer :: res + end function psb_i2_get_base_multivect_default + end interface + + interface + module subroutine i2_mvect_clone(x,y,info) + class(psb_i2_multivect_type), intent(inout) :: x + class(psb_i2_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i2_mvect_clone + end interface + + interface + module subroutine i2_mvect_bld_x(x,invect,mold) + integer(psb_i2pk_), intent(in) :: invect(:,:) + class(psb_i2_multivect_type), intent(out) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + end subroutine i2_mvect_bld_x + end interface + + + interface + module subroutine i2_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(out) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i2_mvect_bld_n + end interface + + interface + module function i2_mvect_get_vect(x) result(res) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:,:) + end function i2_mvect_get_vect + end interface + + interface + module subroutine i2_mvect_set_scal(x,val) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + end subroutine i2_mvect_set_scal + end interface + + interface + module subroutine i2_mvect_set_vect(x,val) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:,:) + end subroutine i2_mvect_set_vect + end interface + + interface + module function i2_mvect_get_nrows(x) result(res) + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_mvect_get_nrows + end interface + + interface + module function i2_mvect_get_ncols(x) result(res) + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_mvect_get_ncols + end interface + + interface + module function i2_mvect_sizeof(x) result(res) + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i2_mvect_sizeof + end interface + + interface + module function i2_mvect_get_fmt(x) result(res) + class(psb_i2_multivect_type), intent(in) :: x + character(len=5) :: res + end function i2_mvect_get_fmt + end interface + + interface + module subroutine i2_mvect_all(m,n, x, info, mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(out) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + end subroutine i2_mvect_all + end interface + + interface + module subroutine i2_mvect_reall(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_mvect_reall + end interface + + interface + module subroutine i2_mvect_zero(x) + class(psb_i2_multivect_type), intent(inout) :: x + end subroutine i2_mvect_zero + end interface + + interface + module subroutine i2_mvect_asb(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_mvect_asb + end interface + + interface + module subroutine i2_mvect_sync(x) + class(psb_i2_multivect_type), intent(inout) :: x + end subroutine i2_mvect_sync + end interface + + interface + module subroutine i2_mvect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_multivect_type) :: x + end subroutine i2_mvect_gthab + end interface + + interface + module subroutine i2_mvect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_multivect_type) :: x + end subroutine i2_mvect_gthzv + end interface + + interface + module subroutine i2_mvect_gthzv_x(i,n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: y(:) + class(psb_i2_multivect_type) :: x + end subroutine i2_mvect_gthzv_x + end interface + + interface + module subroutine i2_mvect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_multivect_type) :: y + end subroutine i2_mvect_sctb + end interface + + interface + module subroutine i2_mvect_sctb_x(i,n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_multivect_type) :: y + end subroutine i2_mvect_sctb_x + end interface + + interface + module subroutine i2_mvect_free(x, info) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_mvect_free + end interface + + interface + module subroutine i2_mvect_ins(n,irl,val,x,maxr,info) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine i2_mvect_ins + end interface + + interface + module subroutine i2_mvect_cnv(x,mold) + class(psb_i2_multivect_type), intent(inout) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + end subroutine i2_mvect_cnv + end interface contains - - function i2_mvect_get_dupl(x) result(res) - implicit none - class(psb_i2_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function i2_mvect_get_dupl - - subroutine i2_mvect_set_dupl(x,val) - implicit none - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ - end if - end subroutine i2_mvect_set_dupl - - - function i2_mvect_is_remote_build(x) result(res) - implicit none - class(psb_i2_multivect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function i2_mvect_is_remote_build - - subroutine i2_mvect_set_remote_build(x,val) - implicit none - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine i2_mvect_set_remote_build - - - subroutine psb_i2_set_multivect_default(v) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: v - - if (allocated(psb_i2_base_multivect_default)) then - deallocate(psb_i2_base_multivect_default) - end if - allocate(psb_i2_base_multivect_default, mold=v) - - end subroutine psb_i2_set_multivect_default - - function psb_i2_get_multivect_default(v) result(res) - implicit none - class(psb_i2_multivect_type), intent(in) :: v - class(psb_i2_base_multivect_type), pointer :: res - - res => psb_i2_get_base_multivect_default() - - end function psb_i2_get_multivect_default - - - function psb_i2_get_base_multivect_default() result(res) - implicit none - class(psb_i2_base_multivect_type), pointer :: res - - if (.not.allocated(psb_i2_base_multivect_default)) then - allocate(psb_i2_base_multivect_type :: psb_i2_base_multivect_default) - end if - - res => psb_i2_base_multivect_default - - end function psb_i2_get_base_multivect_default - - - subroutine i2_mvect_clone(x,y,info) - implicit none - class(psb_i2_multivect_type), intent(inout) :: x - class(psb_i2_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - call y%bld_x(x%get_vect(),mold=x%v) - end if - end subroutine i2_mvect_clone - - subroutine i2_mvect_bld_x(x,invect,mold) - integer(psb_i2pk_), intent(in) :: invect(:,:) - class(psb_i2_multivect_type), intent(out) :: x - class(psb_i2_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - class(psb_i2_base_multivect_type), pointer :: mld - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i2_get_base_multivect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect) - - end subroutine i2_mvect_bld_x - - - subroutine i2_mvect_bld_n(x,m,n,mold,scratch) - integer(psb_ipk_), intent(in) :: m,n - class(psb_i2_multivect_type), intent(out) :: x - class(psb_i2_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i2_get_base_multivect_default()) - endif - if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) - - end subroutine i2_mvect_bld_n - - function i2_mvect_get_vect(x) result(res) - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_i2pk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - res = x%v%get_vect() - end if - end function i2_mvect_get_vect - - subroutine i2_mvect_set_scal(x,val) - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine i2_mvect_set_scal - - subroutine i2_mvect_set_vect(x,val) - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val(:,:) - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine i2_mvect_set_vect - - - function constructor(x) result(this) + function constructor(x) result(this) integer(psb_i2pk_) :: x(:,:) type(psb_i2_multivect_type) :: this integer(psb_ipk_) :: info @@ -1040,7 +848,6 @@ contains end function constructor - function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n type(psb_i2_multivect_type) :: this @@ -1051,223 +858,4 @@ contains end function size_const - function i2_mvect_get_nrows(x) result(res) - implicit none - class(psb_i2_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function i2_mvect_get_nrows - - function i2_mvect_get_ncols(x) result(res) - implicit none - class(psb_i2_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_ncols() - end function i2_mvect_get_ncols - - function i2_mvect_sizeof(x) result(res) - implicit none - class(psb_i2_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function i2_mvect_sizeof - - function i2_mvect_get_fmt(x) result(res) - implicit none - class(psb_i2_multivect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function i2_mvect_get_fmt - - subroutine i2_mvect_all(m,n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i2_multivect_type), intent(out) :: x - class(psb_i2_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_i2_base_multivect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(m,n,info) - else - info = psb_err_alloc_dealloc_ - end if - - end subroutine i2_mvect_all - - subroutine i2_mvect_reall(m,n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(m,n,info) - if (info == 0) & - & call x%asb(m,n,info) - - end subroutine i2_mvect_reall - - subroutine i2_mvect_zero(x) - use psi_serial_mod - implicit none - class(psb_i2_multivect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine i2_mvect_zero - - subroutine i2_mvect_asb(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) & - & call x%v%asb(m,n,info) - - end subroutine i2_mvect_asb - - subroutine i2_mvect_sync(x) - implicit none - class(psb_i2_multivect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine i2_mvect_sync - - subroutine i2_mvect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: alpha, beta, y(:) - class(psb_i2_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine i2_mvect_gthab - - subroutine i2_mvect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: y(:) - class(psb_i2_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine i2_mvect_gthzv - - subroutine i2_mvect_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_i2pk_) :: y(:) - class(psb_i2_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(i,n,idx,y) - - end subroutine i2_mvect_gthzv_x - - subroutine i2_mvect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: beta, x(:) - class(psb_i2_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine i2_mvect_sctb - - subroutine i2_mvect_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_i2pk_) :: beta, x(:) - class(psb_i2_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(i,n,idx,x,beta) - - end subroutine i2_mvect_sctb_x - - subroutine i2_mvect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine i2_mvect_free - - subroutine i2_mvect_ins(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i2_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_i2pk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine i2_mvect_ins - - - subroutine i2_mvect_cnv(x,mold) - class(psb_i2_multivect_type), intent(inout) :: x - class(psb_i2_base_multivect_type), intent(in), optional :: mold - class(psb_i2_base_multivect_type), allocatable :: tmp - integer(psb_ipk_) :: info - - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info, mold=psb_i2_get_base_multivect_default()) - endif - if (allocated(x%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%free(info) - end if - call move_alloc(tmp,x%v) - end subroutine i2_mvect_cnv - - end module psb_i2_multivect_mod - diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index aa8646ee..8a0062e6 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -132,362 +132,391 @@ module psb_i_vect_mod class(psb_i_base_vect_type), allocatable, target,& & save, private :: psb_i_base_vect_default + + interface + module function i_vect_get_dupl(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_vect_get_dupl + end interface + + interface + module subroutine i_vect_set_dupl(x,val) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i_vect_set_dupl + end interface + + interface + module function i_vect_get_ncfs(x) result(res) + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_vect_get_ncfs + end interface + + interface + module subroutine i_vect_set_ncfs(x,val) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i_vect_set_ncfs + end interface + + interface + module function i_vect_get_state(x) result(res) + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_vect_get_state + end interface + + interface + module function i_vect_is_null(x) result(res) + class(psb_i_vect_type), intent(in) :: x + logical :: res + end function i_vect_is_null + end interface + + interface + module function i_vect_is_bld(x) result(res) + class(psb_i_vect_type), intent(in) :: x + logical :: res + end function i_vect_is_bld + end interface + + interface + module function i_vect_is_upd(x) result(res) + class(psb_i_vect_type), intent(in) :: x + logical :: res + end function i_vect_is_upd + end interface + + interface + module function i_vect_is_asb(x) result(res) + class(psb_i_vect_type), intent(in) :: x + logical :: res + end function i_vect_is_asb + end interface + + interface + module subroutine i_vect_set_state(n,x) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i_vect_set_state + end interface + + interface + module subroutine i_vect_set_null(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_set_null + end interface + + interface + module subroutine i_vect_set_bld(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_set_bld + end interface + + interface + module subroutine i_vect_set_upd(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_set_upd + end interface + + interface + module subroutine i_vect_set_asb(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_set_asb + end interface + + interface + module function i_vect_get_nrmv(x) result(res) + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_vect_get_nrmv + end interface + + interface + module subroutine i_vect_set_nrmv(x,val) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine i_vect_set_nrmv + end interface + + interface + module function i_vect_is_remote_build(x) result(res) + class(psb_i_vect_type), intent(in) :: x + logical :: res + end function i_vect_is_remote_build + end interface + + interface + module subroutine i_vect_set_remote_build(x,val) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i_vect_set_remote_build + end interface + interface psb_set_vect_default - module procedure psb_i_set_vect_default - end interface psb_set_vect_default + module subroutine psb_i_set_vect_default(v) + class(psb_i_base_vect_type), intent(in) :: v + end subroutine psb_i_set_vect_default + end interface interface psb_get_vect_default - module procedure psb_i_get_vect_default - end interface psb_get_vect_default - - -contains - - function i_vect_get_dupl(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_dupl() - else - res = psb_dupl_null_ - end if - end function i_vect_get_dupl - - subroutine i_vect_set_dupl(x,val) - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_dupl(val) - else - call x%v%set_dupl(psb_dupl_def_) - end if - end if - end subroutine i_vect_set_dupl - - function i_vect_get_ncfs(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_ncfs() - else - res = 0 - end if - end function i_vect_get_ncfs - - subroutine i_vect_set_ncfs(x,val) - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_ncfs(val) - else - call x%v%set_ncfs(0) - end if - end if - end subroutine i_vect_set_ncfs - - function i_vect_get_state(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_state() - else - res = psb_vect_null_ - end if - end function i_vect_get_state - - function i_vect_is_null(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_null_) - end function i_vect_is_null - - function i_vect_is_bld(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_bld_) - end function i_vect_is_bld - - function i_vect_is_upd(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_upd_) - end function i_vect_is_upd - - function i_vect_is_asb(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_asb_) - end function i_vect_is_asb - - subroutine i_vect_set_state(n,x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - if (allocated(x%v)) then - call x%v%set_state(n) - end if - end subroutine i_vect_set_state - - - subroutine i_vect_set_null(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_null_) - end subroutine i_vect_set_null - - subroutine i_vect_set_bld(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_bld_) - end subroutine i_vect_set_bld - - subroutine i_vect_set_upd(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_upd_) - end subroutine i_vect_set_upd - - subroutine i_vect_set_asb(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_asb_) - end subroutine i_vect_set_asb - - 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 - class(psb_i_vect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function i_vect_is_remote_build - - subroutine i_vect_set_remote_build(x,val) - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine i_vect_set_remote_build - - subroutine psb_i_set_vect_default(v) - implicit none - class(psb_i_base_vect_type), intent(in) :: v - - if (allocated(psb_i_base_vect_default)) then - deallocate(psb_i_base_vect_default) - end if - allocate(psb_i_base_vect_default, mold=v) - - end subroutine psb_i_set_vect_default - - function psb_i_get_vect_default(v) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: v - class(psb_i_base_vect_type), pointer :: res - - res => psb_i_get_base_vect_default() - - end function psb_i_get_vect_default - - subroutine psb_i_clear_vect_default() - implicit none - - if (allocated(psb_i_base_vect_default)) then - deallocate(psb_i_base_vect_default) - end if - - end subroutine psb_i_clear_vect_default - - function psb_i_get_base_vect_default() result(res) - implicit none - class(psb_i_base_vect_type), pointer :: res - - if (.not.allocated(psb_i_base_vect_default)) then - allocate(psb_i_base_vect_type :: psb_i_base_vect_default) - end if - - res => psb_i_base_vect_default - - end function psb_i_get_base_vect_default - - subroutine i_vect_clone(x,y,info) - implicit none - class(psb_i_vect_type), intent(inout) :: x - class(psb_i_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - ! - ! Using sourced allocation here creates - ! problems with handling of memory allocated - ! elsewhere (e.g. accelerators), hence delegation - ! to %bld method - ! - call y%bld(x%get_vect(),mold=x%v) - end if - end subroutine i_vect_clone - - subroutine i_vect_bld_x(x,invect,mold,scratch) - integer(psb_ipk_), intent(in) :: invect(:) - class(psb_i_vect_type), intent(inout) :: x - class(psb_i_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) - - end subroutine i_vect_bld_x - - - subroutine i_vect_bld_mn(x,n,mold,scratch) - integer(psb_mpk_), intent(in) :: n - class(psb_i_vect_type), intent(inout) :: x - class(psb_i_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - class(psb_i_base_vect_type), pointer :: mld - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine i_vect_bld_mn - - subroutine i_vect_bld_en(x,n,mold,scratch) - integer(psb_epk_), intent(in) :: n - class(psb_i_vect_type), intent(inout) :: x - class(psb_i_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine i_vect_bld_en - - function i_vect_get_vect(x,n) result(res) - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - - if (allocated(x%v)) then - res = x%v%get_vect(n) - end if - end function i_vect_get_vect - - subroutine i_vect_set_scal(x,val,first,last) - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine i_vect_set_scal - - subroutine i_vect_set_vect(x,val,first,last) - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) + module function psb_i_get_vect_default(v) result(res) + class(psb_i_vect_type), intent(in) :: v + class(psb_i_base_vect_type), pointer :: res + end function psb_i_get_vect_default + end interface + + interface + module subroutine psb_i_clear_vect_default() + end subroutine psb_i_clear_vect_default + end interface + + interface + module function psb_i_get_base_vect_default() result(res) + class(psb_i_base_vect_type), pointer :: res + end function psb_i_get_base_vect_default + end interface + + interface + module subroutine i_vect_clone(x,y,info) + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i_vect_clone + end interface + + interface + module subroutine i_vect_bld_x(x,invect,mold,scratch) + integer(psb_ipk_), intent(in) :: invect(:) + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i_vect_bld_x + end interface + + interface + module subroutine i_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i_vect_bld_mn + end interface + + interface + module subroutine i_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i_vect_bld_en + end interface + + interface + module function i_vect_get_vect(x,n) result(res) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function i_vect_get_vect + end interface + + interface + module subroutine i_vect_set_scal(x,val,first,last) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine i_vect_set_scal + end interface + + interface + module subroutine i_vect_set_vect(x,val,first,last) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine i_vect_set_vect + end interface + + interface + module subroutine i_vect_check_addr(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_check_addr + end interface + + interface + module function i_vect_get_nrows(x) result(res) + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_vect_get_nrows + end interface + + interface + module function i_vect_sizeof(x) result(res) + class(psb_i_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i_vect_sizeof + end interface + + interface + module function i_vect_get_fmt(x) result(res) + class(psb_i_vect_type), intent(in) :: x + character(len=5) :: res + end function i_vect_get_fmt + end interface + + interface + module subroutine i_vect_all(n, x, info, mold) + 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 + end subroutine i_vect_all + end interface + + interface + module subroutine i_vect_reinit(x, info, clear) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine i_vect_reinit + end interface + + interface + module subroutine i_vect_reall(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_vect_reall + end interface + + interface + module subroutine i_vect_zero(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_zero + end interface + + interface + module subroutine i_vect_asb(n, x, info, scratch) + integer(psb_ipk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine i_vect_asb + end interface + + interface + module subroutine i_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_vect_type) :: x + end subroutine i_vect_gthab + end interface + + interface + module subroutine i_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_vect_type) :: x + end subroutine i_vect_gthzv + end interface + + interface + module subroutine i_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_vect_type) :: y + end subroutine i_vect_sctb + end interface + + interface + module subroutine i_vect_free(x, info) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_vect_free + end interface + + interface + module subroutine i_vect_ins_a(n,irl,val,x,maxr,info) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine i_vect_ins_a + end interface + + interface + module subroutine i_vect_ins_v(n,irl,val,x,maxr,info) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_i_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine i_vect_ins_v + end interface + + interface + module subroutine i_vect_cnv(x,mold) + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + class(psb_i_base_vect_type), allocatable :: tmp + end subroutine i_vect_cnv + end interface + + interface + module subroutine i_vect_sync(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_sync + end interface + + interface + module subroutine i_vect_set_sync(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_set_sync + end interface + + interface + module subroutine i_vect_set_host(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_set_host + end interface + + interface + module subroutine i_vect_set_dev(x) + class(psb_i_vect_type), intent(inout) :: x + end subroutine i_vect_set_dev + end interface + + interface + module function i_vect_is_sync(x) result(res) + logical :: res + class(psb_i_vect_type), intent(inout) :: x + end function i_vect_is_sync + end interface + + interface + module function i_vect_is_host(x) result(res) + logical :: res + class(psb_i_vect_type), intent(inout) :: x + end function i_vect_is_host + end interface + + interface + module function i_vect_is_dev(x) result(res) + logical :: res + class(psb_i_vect_type), intent(inout) :: x + end function i_vect_is_dev + end interface - end subroutine i_vect_set_vect - subroutine i_vect_check_addr(x) - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%check_addr() - end subroutine i_vect_check_addr +contains function constructor(x) result(this) integer(psb_ipk_) :: x(:) @@ -510,299 +539,8 @@ contains end function size_const - function i_vect_get_nrows(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function i_vect_get_nrows - - function i_vect_sizeof(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function i_vect_sizeof - - function i_vect_get_fmt(x) result(res) - implicit none - class(psb_i_vect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function i_vect_get_fmt - - 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 - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_i_base_vect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(n,info) - else - info = psb_err_alloc_dealloc_ - end if - call x%set_bld() - end subroutine i_vect_all - - subroutine i_vect_reinit(x, info, clear) - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - - if (allocated(x%v)) call x%v%reinit(info,clear) - call x%set_upd() - - end subroutine i_vect_reinit - - subroutine i_vect_reall(n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(n,info) - if (info == 0) & - & call x%asb(n,info) - - end subroutine i_vect_reall - - subroutine i_vect_zero(x) - use psi_serial_mod - implicit none - class(psb_i_vect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine i_vect_zero - - subroutine i_vect_asb(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - if (allocated(x%v)) then - call x%v%asb(n,info,scratch=scratch) - call x%set_asb() - end if - end subroutine i_vect_asb - - subroutine i_vect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: alpha, beta, y(:) - class(psb_i_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine i_vect_gthab - - subroutine i_vect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: y(:) - class(psb_i_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine i_vect_gthzv - - subroutine i_vect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: beta, x(:) - class(psb_i_vect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine i_vect_sctb - - subroutine i_vect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine i_vect_free - - subroutine i_vect_ins_a(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine i_vect_ins_a - - subroutine i_vect_ins_v(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - 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, 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,maxr,info) - - end subroutine i_vect_ins_v - - - subroutine i_vect_cnv(x,mold) - class(psb_i_vect_type), intent(inout) :: x - class(psb_i_base_vect_type), intent(in), optional :: mold - class(psb_i_base_vect_type), allocatable :: tmp - - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info,mold=psb_i_get_base_vect_default()) - end if - if (allocated(x%v)) then - if (allocated(x%v%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%base_cpy(tmp) - call x%v%free(info) - endif - end if - call move_alloc(tmp,x%v) - - end subroutine i_vect_cnv - - - subroutine i_vect_sync(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine i_vect_sync - - subroutine i_vect_set_sync(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_sync() - - end subroutine i_vect_set_sync - - subroutine i_vect_set_host(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_host() - - end subroutine i_vect_set_host - - subroutine i_vect_set_dev(x) - implicit none - class(psb_i_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_dev() - - end subroutine i_vect_set_dev - - function i_vect_is_sync(x) result(res) - implicit none - logical :: res - class(psb_i_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_sync() - - end function i_vect_is_sync - - function i_vect_is_host(x) result(res) - implicit none - logical :: res - class(psb_i_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_host() - - end function i_vect_is_host - - function i_vect_is_dev(x) result(res) - implicit none - logical :: res - class(psb_i_vect_type), intent(inout) :: x - - res = .false. - if (allocated(x%v)) & - & res = x%v%is_dev() - - end function i_vect_is_dev - - - - end module psb_i_vect_mod - module psb_i_multivect_mod use psb_i_base_multivect_mod @@ -865,171 +603,241 @@ module psb_i_multivect_mod class(psb_i_base_multivect_type), allocatable, target,& & save, private :: psb_i_base_multivect_default - interface psb_set_multivect_default - module procedure psb_i_set_multivect_default - end interface psb_set_multivect_default - - interface psb_get_multivect_default - module procedure psb_i_get_multivect_default - end interface psb_get_multivect_default + + interface + module function i_mvect_get_dupl(x) result(res) + class(psb_i_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_mvect_get_dupl + end interface + + interface + module subroutine i_mvect_set_dupl(x,val) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i_mvect_set_dupl + end interface + + interface + module function i_mvect_is_remote_build(x) result(res) + class(psb_i_multivect_type), intent(in) :: x + logical :: res + end function i_mvect_is_remote_build + end interface + + interface + module subroutine i_mvect_set_remote_build(x,val) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine i_mvect_set_remote_build + end interface + + interface + module subroutine psb_i_set_multivect_default(v) + class(psb_i_base_multivect_type), intent(in) :: v + end subroutine psb_i_set_multivect_default + end interface + + interface + module function psb_i_get_multivect_default(v) result(res) + class(psb_i_multivect_type), intent(in) :: v + class(psb_i_base_multivect_type), pointer :: res + end function psb_i_get_multivect_default + end interface + + interface + module function psb_i_get_base_multivect_default() result(res) + class(psb_i_base_multivect_type), pointer :: res + end function psb_i_get_base_multivect_default + end interface + + interface + module subroutine i_mvect_clone(x,y,info) + class(psb_i_multivect_type), intent(inout) :: x + class(psb_i_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i_mvect_clone + end interface + + interface + module subroutine i_mvect_bld_x(x,invect,mold) + integer(psb_ipk_), intent(in) :: invect(:,:) + class(psb_i_multivect_type), intent(out) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + end subroutine i_mvect_bld_x + end interface + + + interface + module subroutine i_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(out) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine i_mvect_bld_n + end interface + + interface + module function i_mvect_get_vect(x) result(res) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:,:) + end function i_mvect_get_vect + end interface + + interface + module subroutine i_mvect_set_scal(x,val) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine i_mvect_set_scal + end interface + + interface + module subroutine i_mvect_set_vect(x,val) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:,:) + end subroutine i_mvect_set_vect + end interface + + interface + module function i_mvect_get_nrows(x) result(res) + class(psb_i_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_mvect_get_nrows + end interface + + interface + module function i_mvect_get_ncols(x) result(res) + class(psb_i_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_mvect_get_ncols + end interface + + interface + module function i_mvect_sizeof(x) result(res) + class(psb_i_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i_mvect_sizeof + end interface + + interface + module function i_mvect_get_fmt(x) result(res) + class(psb_i_multivect_type), intent(in) :: x + character(len=5) :: res + end function i_mvect_get_fmt + end interface + + interface + module subroutine i_mvect_all(m,n, x, info, mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(out) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + end subroutine i_mvect_all + end interface + + interface + module subroutine i_mvect_reall(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_mvect_reall + end interface + + interface + module subroutine i_mvect_zero(x) + class(psb_i_multivect_type), intent(inout) :: x + end subroutine i_mvect_zero + end interface + + interface + module subroutine i_mvect_asb(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_mvect_asb + end interface + + interface + module subroutine i_mvect_sync(x) + class(psb_i_multivect_type), intent(inout) :: x + end subroutine i_mvect_sync + end interface + + interface + module subroutine i_mvect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_multivect_type) :: x + end subroutine i_mvect_gthab + end interface + + interface + module subroutine i_mvect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_multivect_type) :: x + end subroutine i_mvect_gthzv + end interface + + interface + module subroutine i_mvect_gthzv_x(i,n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: y(:) + class(psb_i_multivect_type) :: x + end subroutine i_mvect_gthzv_x + end interface + + interface + module subroutine i_mvect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_multivect_type) :: y + end subroutine i_mvect_sctb + end interface + + interface + module subroutine i_mvect_sctb_x(i,n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta, x(:) + class(psb_i_multivect_type) :: y + end subroutine i_mvect_sctb_x + end interface + + interface + module subroutine i_mvect_free(x, info) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_mvect_free + end interface + + interface + module subroutine i_mvect_ins(n,irl,val,x,maxr,info) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine i_mvect_ins + end interface + + interface + module subroutine i_mvect_cnv(x,mold) + class(psb_i_multivect_type), intent(inout) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + end subroutine i_mvect_cnv + end interface contains - - function i_mvect_get_dupl(x) result(res) - implicit none - class(psb_i_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function i_mvect_get_dupl - - subroutine i_mvect_set_dupl(x,val) - implicit none - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ - end if - end subroutine i_mvect_set_dupl - - - function i_mvect_is_remote_build(x) result(res) - implicit none - class(psb_i_multivect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function i_mvect_is_remote_build - - subroutine i_mvect_set_remote_build(x,val) - implicit none - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine i_mvect_set_remote_build - - - subroutine psb_i_set_multivect_default(v) - implicit none - class(psb_i_base_multivect_type), intent(in) :: v - - if (allocated(psb_i_base_multivect_default)) then - deallocate(psb_i_base_multivect_default) - end if - allocate(psb_i_base_multivect_default, mold=v) - - end subroutine psb_i_set_multivect_default - - function psb_i_get_multivect_default(v) result(res) - implicit none - class(psb_i_multivect_type), intent(in) :: v - class(psb_i_base_multivect_type), pointer :: res - - res => psb_i_get_base_multivect_default() - - end function psb_i_get_multivect_default - - - function psb_i_get_base_multivect_default() result(res) - implicit none - class(psb_i_base_multivect_type), pointer :: res - - if (.not.allocated(psb_i_base_multivect_default)) then - allocate(psb_i_base_multivect_type :: psb_i_base_multivect_default) - end if - - res => psb_i_base_multivect_default - - end function psb_i_get_base_multivect_default - - - subroutine i_mvect_clone(x,y,info) - implicit none - class(psb_i_multivect_type), intent(inout) :: x - class(psb_i_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - call y%bld_x(x%get_vect(),mold=x%v) - end if - end subroutine i_mvect_clone - - subroutine i_mvect_bld_x(x,invect,mold) - integer(psb_ipk_), intent(in) :: invect(:,:) - class(psb_i_multivect_type), intent(out) :: x - class(psb_i_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - class(psb_i_base_multivect_type), pointer :: mld - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect) - - end subroutine i_mvect_bld_x - - - subroutine i_mvect_bld_n(x,m,n,mold,scratch) - integer(psb_ipk_), intent(in) :: m,n - class(psb_i_multivect_type), intent(out) :: x - class(psb_i_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) - endif - if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) - - end subroutine i_mvect_bld_n - - function i_mvect_get_vect(x) result(res) - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - res = x%v%get_vect() - end if - end function i_mvect_get_vect - - subroutine i_mvect_set_scal(x,val) - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine i_mvect_set_scal - - subroutine i_mvect_set_vect(x,val) - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val(:,:) - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine i_mvect_set_vect - - - function constructor(x) result(this) + function constructor(x) result(this) integer(psb_ipk_) :: x(:,:) type(psb_i_multivect_type) :: this integer(psb_ipk_) :: info @@ -1039,7 +847,6 @@ contains end function constructor - function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n type(psb_i_multivect_type) :: this @@ -1050,223 +857,4 @@ contains end function size_const - function i_mvect_get_nrows(x) result(res) - implicit none - class(psb_i_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function i_mvect_get_nrows - - function i_mvect_get_ncols(x) result(res) - implicit none - class(psb_i_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_ncols() - end function i_mvect_get_ncols - - function i_mvect_sizeof(x) result(res) - implicit none - class(psb_i_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function i_mvect_sizeof - - function i_mvect_get_fmt(x) result(res) - implicit none - class(psb_i_multivect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function i_mvect_get_fmt - - subroutine i_mvect_all(m,n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i_multivect_type), intent(out) :: x - class(psb_i_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_i_base_multivect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(m,n,info) - else - info = psb_err_alloc_dealloc_ - end if - - end subroutine i_mvect_all - - subroutine i_mvect_reall(m,n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(m,n,info) - if (info == 0) & - & call x%asb(m,n,info) - - end subroutine i_mvect_reall - - subroutine i_mvect_zero(x) - use psi_serial_mod - implicit none - class(psb_i_multivect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine i_mvect_zero - - subroutine i_mvect_asb(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) & - & call x%v%asb(m,n,info) - - end subroutine i_mvect_asb - - subroutine i_mvect_sync(x) - implicit none - class(psb_i_multivect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine i_mvect_sync - - subroutine i_mvect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: alpha, beta, y(:) - class(psb_i_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine i_mvect_gthab - - subroutine i_mvect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: y(:) - class(psb_i_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine i_mvect_gthzv - - subroutine i_mvect_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_ipk_) :: y(:) - class(psb_i_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(i,n,idx,y) - - end subroutine i_mvect_gthzv_x - - subroutine i_mvect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: beta, x(:) - class(psb_i_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine i_mvect_sctb - - subroutine i_mvect_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_ipk_) :: beta, x(:) - class(psb_i_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(i,n,idx,x,beta) - - end subroutine i_mvect_sctb_x - - subroutine i_mvect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine i_mvect_free - - subroutine i_mvect_ins(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_ipk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine i_mvect_ins - - - subroutine i_mvect_cnv(x,mold) - class(psb_i_multivect_type), intent(inout) :: x - class(psb_i_base_multivect_type), intent(in), optional :: mold - class(psb_i_base_multivect_type), allocatable :: tmp - integer(psb_ipk_) :: info - - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info, mold=psb_i_get_base_multivect_default()) - endif - if (allocated(x%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%free(info) - end if - call move_alloc(tmp,x%v) - end subroutine i_mvect_cnv - - end module psb_i_multivect_mod - diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index d876d21e..7a2f2e3c 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -133,362 +133,391 @@ module psb_l_vect_mod class(psb_l_base_vect_type), allocatable, target,& & save, private :: psb_l_base_vect_default + + interface + module function l_vect_get_dupl(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_vect_get_dupl + end interface + + interface + module subroutine l_vect_set_dupl(x,val) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine l_vect_set_dupl + end interface + + interface + module function l_vect_get_ncfs(x) result(res) + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_vect_get_ncfs + end interface + + interface + module subroutine l_vect_set_ncfs(x,val) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine l_vect_set_ncfs + end interface + + interface + module function l_vect_get_state(x) result(res) + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_vect_get_state + end interface + + interface + module function l_vect_is_null(x) result(res) + class(psb_l_vect_type), intent(in) :: x + logical :: res + end function l_vect_is_null + end interface + + interface + module function l_vect_is_bld(x) result(res) + class(psb_l_vect_type), intent(in) :: x + logical :: res + end function l_vect_is_bld + end interface + + interface + module function l_vect_is_upd(x) result(res) + class(psb_l_vect_type), intent(in) :: x + logical :: res + end function l_vect_is_upd + end interface + + interface + module function l_vect_is_asb(x) result(res) + class(psb_l_vect_type), intent(in) :: x + logical :: res + end function l_vect_is_asb + end interface + + interface + module subroutine l_vect_set_state(n,x) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine l_vect_set_state + end interface + + interface + module subroutine l_vect_set_null(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_set_null + end interface + + interface + module subroutine l_vect_set_bld(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_set_bld + end interface + + interface + module subroutine l_vect_set_upd(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_set_upd + end interface + + interface + module subroutine l_vect_set_asb(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_set_asb + end interface + + interface + module function l_vect_get_nrmv(x) result(res) + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_vect_get_nrmv + end interface + + interface + module subroutine l_vect_set_nrmv(x,val) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine l_vect_set_nrmv + end interface + + interface + module function l_vect_is_remote_build(x) result(res) + class(psb_l_vect_type), intent(in) :: x + logical :: res + end function l_vect_is_remote_build + end interface + + interface + module subroutine l_vect_set_remote_build(x,val) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine l_vect_set_remote_build + end interface + interface psb_set_vect_default - module procedure psb_l_set_vect_default - end interface psb_set_vect_default + module subroutine psb_l_set_vect_default(v) + class(psb_l_base_vect_type), intent(in) :: v + end subroutine psb_l_set_vect_default + end interface interface psb_get_vect_default - module procedure psb_l_get_vect_default - end interface psb_get_vect_default - - -contains - - function l_vect_get_dupl(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_dupl() - else - res = psb_dupl_null_ - end if - end function l_vect_get_dupl - - subroutine l_vect_set_dupl(x,val) - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_dupl(val) - else - call x%v%set_dupl(psb_dupl_def_) - end if - end if - end subroutine l_vect_set_dupl - - function l_vect_get_ncfs(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_ncfs() - else - res = 0 - end if - end function l_vect_get_ncfs - - subroutine l_vect_set_ncfs(x,val) - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_ncfs(val) - else - call x%v%set_ncfs(0) - end if - end if - end subroutine l_vect_set_ncfs - - function l_vect_get_state(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_state() - else - res = psb_vect_null_ - end if - end function l_vect_get_state - - function l_vect_is_null(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_null_) - end function l_vect_is_null - - function l_vect_is_bld(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_bld_) - end function l_vect_is_bld - - function l_vect_is_upd(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_upd_) - end function l_vect_is_upd - - function l_vect_is_asb(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_asb_) - end function l_vect_is_asb - - subroutine l_vect_set_state(n,x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - if (allocated(x%v)) then - call x%v%set_state(n) - end if - end subroutine l_vect_set_state - - - subroutine l_vect_set_null(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_null_) - end subroutine l_vect_set_null - - subroutine l_vect_set_bld(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_bld_) - end subroutine l_vect_set_bld - - subroutine l_vect_set_upd(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_upd_) - end subroutine l_vect_set_upd - - subroutine l_vect_set_asb(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_asb_) - end subroutine l_vect_set_asb - - 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 - class(psb_l_vect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function l_vect_is_remote_build - - subroutine l_vect_set_remote_build(x,val) - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine l_vect_set_remote_build - - subroutine psb_l_set_vect_default(v) - implicit none - class(psb_l_base_vect_type), intent(in) :: v - - if (allocated(psb_l_base_vect_default)) then - deallocate(psb_l_base_vect_default) - end if - allocate(psb_l_base_vect_default, mold=v) - - end subroutine psb_l_set_vect_default - - function psb_l_get_vect_default(v) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: v - class(psb_l_base_vect_type), pointer :: res - - res => psb_l_get_base_vect_default() - - end function psb_l_get_vect_default - - subroutine psb_l_clear_vect_default() - implicit none - - if (allocated(psb_l_base_vect_default)) then - deallocate(psb_l_base_vect_default) - end if - - end subroutine psb_l_clear_vect_default - - function psb_l_get_base_vect_default() result(res) - implicit none - class(psb_l_base_vect_type), pointer :: res - - if (.not.allocated(psb_l_base_vect_default)) then - allocate(psb_l_base_vect_type :: psb_l_base_vect_default) - end if - - res => psb_l_base_vect_default - - end function psb_l_get_base_vect_default - - subroutine l_vect_clone(x,y,info) - implicit none - class(psb_l_vect_type), intent(inout) :: x - class(psb_l_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - ! - ! Using sourced allocation here creates - ! problems with handling of memory allocated - ! elsewhere (e.g. accelerators), hence delegation - ! to %bld method - ! - call y%bld(x%get_vect(),mold=x%v) - end if - end subroutine l_vect_clone - - subroutine l_vect_bld_x(x,invect,mold,scratch) - integer(psb_lpk_), intent(in) :: invect(:) - class(psb_l_vect_type), intent(inout) :: x - class(psb_l_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) - - end subroutine l_vect_bld_x - - - subroutine l_vect_bld_mn(x,n,mold,scratch) - integer(psb_mpk_), intent(in) :: n - class(psb_l_vect_type), intent(inout) :: x - class(psb_l_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - class(psb_l_base_vect_type), pointer :: mld - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine l_vect_bld_mn - - subroutine l_vect_bld_en(x,n,mold,scratch) - integer(psb_epk_), intent(in) :: n - class(psb_l_vect_type), intent(inout) :: x - class(psb_l_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine l_vect_bld_en - - function l_vect_get_vect(x,n) result(res) - class(psb_l_vect_type), intent(inout) :: x - integer(psb_lpk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - - if (allocated(x%v)) then - res = x%v%get_vect(n) - end if - end function l_vect_get_vect - - subroutine l_vect_set_scal(x,val,first,last) - class(psb_l_vect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine l_vect_set_scal - - subroutine l_vect_set_vect(x,val,first,last) - class(psb_l_vect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) + module function psb_l_get_vect_default(v) result(res) + class(psb_l_vect_type), intent(in) :: v + class(psb_l_base_vect_type), pointer :: res + end function psb_l_get_vect_default + end interface + + interface + module subroutine psb_l_clear_vect_default() + end subroutine psb_l_clear_vect_default + end interface + + interface + module function psb_l_get_base_vect_default() result(res) + class(psb_l_base_vect_type), pointer :: res + end function psb_l_get_base_vect_default + end interface + + interface + module subroutine l_vect_clone(x,y,info) + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine l_vect_clone + end interface + + interface + module subroutine l_vect_bld_x(x,invect,mold,scratch) + integer(psb_lpk_), intent(in) :: invect(:) + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine l_vect_bld_x + end interface + + interface + module subroutine l_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine l_vect_bld_mn + end interface + + interface + module subroutine l_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine l_vect_bld_en + end interface + + interface + module function l_vect_get_vect(x,n) result(res) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function l_vect_get_vect + end interface + + interface + module subroutine l_vect_set_scal(x,val,first,last) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine l_vect_set_scal + end interface + + interface + module subroutine l_vect_set_vect(x,val,first,last) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine l_vect_set_vect + end interface + + interface + module subroutine l_vect_check_addr(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_check_addr + end interface + + interface + module function l_vect_get_nrows(x) result(res) + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_vect_get_nrows + end interface + + interface + module function l_vect_sizeof(x) result(res) + class(psb_l_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function l_vect_sizeof + end interface + + interface + module function l_vect_get_fmt(x) result(res) + class(psb_l_vect_type), intent(in) :: x + character(len=5) :: res + end function l_vect_get_fmt + end interface + + interface + module subroutine l_vect_all(n, x, info, mold) + 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 + end subroutine l_vect_all + end interface + + interface + module subroutine l_vect_reinit(x, info, clear) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine l_vect_reinit + end interface + + interface + module subroutine l_vect_reall(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_vect_reall + end interface + + interface + module subroutine l_vect_zero(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_zero + end interface + + interface + module subroutine l_vect_asb(n, x, info, scratch) + integer(psb_ipk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine l_vect_asb + end interface + + interface + module subroutine l_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_vect_type) :: x + end subroutine l_vect_gthab + end interface + + interface + module subroutine l_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_vect_type) :: x + end subroutine l_vect_gthzv + end interface + + interface + module subroutine l_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_vect_type) :: y + end subroutine l_vect_sctb + end interface + + interface + module subroutine l_vect_free(x, info) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_vect_free + end interface + + interface + module subroutine l_vect_ins_a(n,irl,val,x,maxr,info) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine l_vect_ins_a + end interface + + interface + module subroutine l_vect_ins_v(n,irl,val,x,maxr,info) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_l_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine l_vect_ins_v + end interface + + interface + module subroutine l_vect_cnv(x,mold) + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + class(psb_l_base_vect_type), allocatable :: tmp + end subroutine l_vect_cnv + end interface + + interface + module subroutine l_vect_sync(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_sync + end interface + + interface + module subroutine l_vect_set_sync(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_set_sync + end interface + + interface + module subroutine l_vect_set_host(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_set_host + end interface + + interface + module subroutine l_vect_set_dev(x) + class(psb_l_vect_type), intent(inout) :: x + end subroutine l_vect_set_dev + end interface + + interface + module function l_vect_is_sync(x) result(res) + logical :: res + class(psb_l_vect_type), intent(inout) :: x + end function l_vect_is_sync + end interface + + interface + module function l_vect_is_host(x) result(res) + logical :: res + class(psb_l_vect_type), intent(inout) :: x + end function l_vect_is_host + end interface + + interface + module function l_vect_is_dev(x) result(res) + logical :: res + class(psb_l_vect_type), intent(inout) :: x + end function l_vect_is_dev + end interface - end subroutine l_vect_set_vect - subroutine l_vect_check_addr(x) - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%check_addr() - end subroutine l_vect_check_addr +contains function constructor(x) result(this) integer(psb_lpk_) :: x(:) @@ -511,299 +540,8 @@ contains end function size_const - function l_vect_get_nrows(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function l_vect_get_nrows - - function l_vect_sizeof(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function l_vect_sizeof - - function l_vect_get_fmt(x) result(res) - implicit none - class(psb_l_vect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function l_vect_get_fmt - - 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 - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_l_base_vect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(n,info) - else - info = psb_err_alloc_dealloc_ - end if - call x%set_bld() - end subroutine l_vect_all - - subroutine l_vect_reinit(x, info, clear) - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - - if (allocated(x%v)) call x%v%reinit(info,clear) - call x%set_upd() - - end subroutine l_vect_reinit - - subroutine l_vect_reall(n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(n,info) - if (info == 0) & - & call x%asb(n,info) - - end subroutine l_vect_reall - - subroutine l_vect_zero(x) - use psi_serial_mod - implicit none - class(psb_l_vect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine l_vect_zero - - subroutine l_vect_asb(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - if (allocated(x%v)) then - call x%v%asb(n,info,scratch=scratch) - call x%set_asb() - end if - end subroutine l_vect_asb - - subroutine l_vect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: alpha, beta, y(:) - class(psb_l_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine l_vect_gthab - - subroutine l_vect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: y(:) - class(psb_l_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine l_vect_gthzv - - subroutine l_vect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: beta, x(:) - class(psb_l_vect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine l_vect_sctb - - subroutine l_vect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine l_vect_free - - subroutine l_vect_ins_a(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_lpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine l_vect_ins_a - - subroutine l_vect_ins_v(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_l_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - 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, 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,maxr,info) - - end subroutine l_vect_ins_v - - - subroutine l_vect_cnv(x,mold) - class(psb_l_vect_type), intent(inout) :: x - class(psb_l_base_vect_type), intent(in), optional :: mold - class(psb_l_base_vect_type), allocatable :: tmp - - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info,mold=psb_l_get_base_vect_default()) - end if - if (allocated(x%v)) then - if (allocated(x%v%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%base_cpy(tmp) - call x%v%free(info) - endif - end if - call move_alloc(tmp,x%v) - - end subroutine l_vect_cnv - - - subroutine l_vect_sync(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine l_vect_sync - - subroutine l_vect_set_sync(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_sync() - - end subroutine l_vect_set_sync - - subroutine l_vect_set_host(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_host() - - end subroutine l_vect_set_host - - subroutine l_vect_set_dev(x) - implicit none - class(psb_l_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_dev() - - end subroutine l_vect_set_dev - - function l_vect_is_sync(x) result(res) - implicit none - logical :: res - class(psb_l_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_sync() - - end function l_vect_is_sync - - function l_vect_is_host(x) result(res) - implicit none - logical :: res - class(psb_l_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_host() - - end function l_vect_is_host - - function l_vect_is_dev(x) result(res) - implicit none - logical :: res - class(psb_l_vect_type), intent(inout) :: x - - res = .false. - if (allocated(x%v)) & - & res = x%v%is_dev() - - end function l_vect_is_dev - - - - end module psb_l_vect_mod - module psb_l_multivect_mod use psb_l_base_multivect_mod @@ -866,171 +604,241 @@ module psb_l_multivect_mod class(psb_l_base_multivect_type), allocatable, target,& & save, private :: psb_l_base_multivect_default - interface psb_set_multivect_default - module procedure psb_l_set_multivect_default - end interface psb_set_multivect_default - - interface psb_get_multivect_default - module procedure psb_l_get_multivect_default - end interface psb_get_multivect_default + + interface + module function l_mvect_get_dupl(x) result(res) + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_mvect_get_dupl + end interface + + interface + module subroutine l_mvect_set_dupl(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine l_mvect_set_dupl + end interface + + interface + module function l_mvect_is_remote_build(x) result(res) + class(psb_l_multivect_type), intent(in) :: x + logical :: res + end function l_mvect_is_remote_build + end interface + + interface + module subroutine l_mvect_set_remote_build(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine l_mvect_set_remote_build + end interface + + interface + module subroutine psb_l_set_multivect_default(v) + class(psb_l_base_multivect_type), intent(in) :: v + end subroutine psb_l_set_multivect_default + end interface + + interface + module function psb_l_get_multivect_default(v) result(res) + class(psb_l_multivect_type), intent(in) :: v + class(psb_l_base_multivect_type), pointer :: res + end function psb_l_get_multivect_default + end interface + + interface + module function psb_l_get_base_multivect_default() result(res) + class(psb_l_base_multivect_type), pointer :: res + end function psb_l_get_base_multivect_default + end interface + + interface + module subroutine l_mvect_clone(x,y,info) + class(psb_l_multivect_type), intent(inout) :: x + class(psb_l_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine l_mvect_clone + end interface + + interface + module subroutine l_mvect_bld_x(x,invect,mold) + integer(psb_lpk_), intent(in) :: invect(:,:) + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + end subroutine l_mvect_bld_x + end interface + + + interface + module subroutine l_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine l_mvect_bld_n + end interface + + interface + module function l_mvect_get_vect(x) result(res) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:,:) + end function l_mvect_get_vect + end interface + + interface + module subroutine l_mvect_set_scal(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + end subroutine l_mvect_set_scal + end interface + + interface + module subroutine l_mvect_set_vect(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:,:) + end subroutine l_mvect_set_vect + end interface + + interface + module function l_mvect_get_nrows(x) result(res) + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_mvect_get_nrows + end interface + + interface + module function l_mvect_get_ncols(x) result(res) + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_mvect_get_ncols + end interface + + interface + module function l_mvect_sizeof(x) result(res) + class(psb_l_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function l_mvect_sizeof + end interface + + interface + module function l_mvect_get_fmt(x) result(res) + class(psb_l_multivect_type), intent(in) :: x + character(len=5) :: res + end function l_mvect_get_fmt + end interface + + interface + module subroutine l_mvect_all(m,n, x, info, mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + end subroutine l_mvect_all + end interface + + interface + module subroutine l_mvect_reall(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_mvect_reall + end interface + + interface + module subroutine l_mvect_zero(x) + class(psb_l_multivect_type), intent(inout) :: x + end subroutine l_mvect_zero + end interface + + interface + module subroutine l_mvect_asb(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_mvect_asb + end interface + + interface + module subroutine l_mvect_sync(x) + class(psb_l_multivect_type), intent(inout) :: x + end subroutine l_mvect_sync + end interface + + interface + module subroutine l_mvect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_multivect_type) :: x + end subroutine l_mvect_gthab + end interface + + interface + module subroutine l_mvect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_multivect_type) :: x + end subroutine l_mvect_gthzv + end interface + + interface + module subroutine l_mvect_gthzv_x(i,n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: y(:) + class(psb_l_multivect_type) :: x + end subroutine l_mvect_gthzv_x + end interface + + interface + module subroutine l_mvect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_multivect_type) :: y + end subroutine l_mvect_sctb + end interface + + interface + module subroutine l_mvect_sctb_x(i,n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta, x(:) + class(psb_l_multivect_type) :: y + end subroutine l_mvect_sctb_x + end interface + + interface + module subroutine l_mvect_free(x, info) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_mvect_free + end interface + + interface + module subroutine l_mvect_ins(n,irl,val,x,maxr,info) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine l_mvect_ins + end interface + + interface + module subroutine l_mvect_cnv(x,mold) + class(psb_l_multivect_type), intent(inout) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + end subroutine l_mvect_cnv + end interface contains - - function l_mvect_get_dupl(x) result(res) - implicit none - class(psb_l_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function l_mvect_get_dupl - - subroutine l_mvect_set_dupl(x,val) - implicit none - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ - end if - end subroutine l_mvect_set_dupl - - - function l_mvect_is_remote_build(x) result(res) - implicit none - class(psb_l_multivect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function l_mvect_is_remote_build - - subroutine l_mvect_set_remote_build(x,val) - implicit none - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine l_mvect_set_remote_build - - - subroutine psb_l_set_multivect_default(v) - implicit none - class(psb_l_base_multivect_type), intent(in) :: v - - if (allocated(psb_l_base_multivect_default)) then - deallocate(psb_l_base_multivect_default) - end if - allocate(psb_l_base_multivect_default, mold=v) - - end subroutine psb_l_set_multivect_default - - function psb_l_get_multivect_default(v) result(res) - implicit none - class(psb_l_multivect_type), intent(in) :: v - class(psb_l_base_multivect_type), pointer :: res - - res => psb_l_get_base_multivect_default() - - end function psb_l_get_multivect_default - - - function psb_l_get_base_multivect_default() result(res) - implicit none - class(psb_l_base_multivect_type), pointer :: res - - if (.not.allocated(psb_l_base_multivect_default)) then - allocate(psb_l_base_multivect_type :: psb_l_base_multivect_default) - end if - - res => psb_l_base_multivect_default - - end function psb_l_get_base_multivect_default - - - subroutine l_mvect_clone(x,y,info) - implicit none - class(psb_l_multivect_type), intent(inout) :: x - class(psb_l_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - call y%bld_x(x%get_vect(),mold=x%v) - end if - end subroutine l_mvect_clone - - subroutine l_mvect_bld_x(x,invect,mold) - integer(psb_lpk_), intent(in) :: invect(:,:) - class(psb_l_multivect_type), intent(out) :: x - class(psb_l_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - class(psb_l_base_multivect_type), pointer :: mld - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect) - - end subroutine l_mvect_bld_x - - - subroutine l_mvect_bld_n(x,m,n,mold,scratch) - integer(psb_ipk_), intent(in) :: m,n - class(psb_l_multivect_type), intent(out) :: x - class(psb_l_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) - endif - if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) - - end subroutine l_mvect_bld_n - - function l_mvect_get_vect(x) result(res) - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_lpk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - res = x%v%get_vect() - end if - end function l_mvect_get_vect - - subroutine l_mvect_set_scal(x,val) - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine l_mvect_set_scal - - subroutine l_mvect_set_vect(x,val) - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val(:,:) - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine l_mvect_set_vect - - - function constructor(x) result(this) + function constructor(x) result(this) integer(psb_lpk_) :: x(:,:) type(psb_l_multivect_type) :: this integer(psb_ipk_) :: info @@ -1040,7 +848,6 @@ contains end function constructor - function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n type(psb_l_multivect_type) :: this @@ -1051,223 +858,4 @@ contains end function size_const - function l_mvect_get_nrows(x) result(res) - implicit none - class(psb_l_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function l_mvect_get_nrows - - function l_mvect_get_ncols(x) result(res) - implicit none - class(psb_l_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_ncols() - end function l_mvect_get_ncols - - function l_mvect_sizeof(x) result(res) - implicit none - class(psb_l_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function l_mvect_sizeof - - function l_mvect_get_fmt(x) result(res) - implicit none - class(psb_l_multivect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function l_mvect_get_fmt - - subroutine l_mvect_all(m,n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_l_multivect_type), intent(out) :: x - class(psb_l_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_l_base_multivect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(m,n,info) - else - info = psb_err_alloc_dealloc_ - end if - - end subroutine l_mvect_all - - subroutine l_mvect_reall(m,n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(m,n,info) - if (info == 0) & - & call x%asb(m,n,info) - - end subroutine l_mvect_reall - - subroutine l_mvect_zero(x) - use psi_serial_mod - implicit none - class(psb_l_multivect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine l_mvect_zero - - subroutine l_mvect_asb(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) & - & call x%v%asb(m,n,info) - - end subroutine l_mvect_asb - - subroutine l_mvect_sync(x) - implicit none - class(psb_l_multivect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine l_mvect_sync - - subroutine l_mvect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: alpha, beta, y(:) - class(psb_l_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine l_mvect_gthab - - subroutine l_mvect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: y(:) - class(psb_l_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine l_mvect_gthzv - - subroutine l_mvect_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_lpk_) :: y(:) - class(psb_l_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(i,n,idx,y) - - end subroutine l_mvect_gthzv_x - - subroutine l_mvect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: beta, x(:) - class(psb_l_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine l_mvect_sctb - - subroutine l_mvect_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_lpk_) :: beta, x(:) - class(psb_l_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(i,n,idx,x,beta) - - end subroutine l_mvect_sctb_x - - subroutine l_mvect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine l_mvect_free - - subroutine l_mvect_ins(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_l_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_lpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine l_mvect_ins - - - subroutine l_mvect_cnv(x,mold) - class(psb_l_multivect_type), intent(inout) :: x - class(psb_l_base_multivect_type), intent(in), optional :: mold - class(psb_l_base_multivect_type), allocatable :: tmp - integer(psb_ipk_) :: info - - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info, mold=psb_l_get_base_multivect_default()) - endif - if (allocated(x%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%free(info) - end if - call move_alloc(tmp,x%v) - end subroutine l_mvect_cnv - - end module psb_l_multivect_mod - diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index cd011667..57ba7b69 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -195,363 +195,785 @@ module psb_s_vect_mod class(psb_s_base_vect_type), allocatable, target,& & save, private :: psb_s_base_vect_default + + interface + module function s_vect_get_dupl(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_vect_get_dupl + end interface + + interface + module subroutine s_vect_set_dupl(x,val) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine s_vect_set_dupl + end interface + + interface + module function s_vect_get_ncfs(x) result(res) + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_vect_get_ncfs + end interface + + interface + module subroutine s_vect_set_ncfs(x,val) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine s_vect_set_ncfs + end interface + + interface + module function s_vect_get_state(x) result(res) + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_vect_get_state + end interface + + interface + module function s_vect_is_null(x) result(res) + class(psb_s_vect_type), intent(in) :: x + logical :: res + end function s_vect_is_null + end interface + + interface + module function s_vect_is_bld(x) result(res) + class(psb_s_vect_type), intent(in) :: x + logical :: res + end function s_vect_is_bld + end interface + + interface + module function s_vect_is_upd(x) result(res) + class(psb_s_vect_type), intent(in) :: x + logical :: res + end function s_vect_is_upd + end interface + + interface + module function s_vect_is_asb(x) result(res) + class(psb_s_vect_type), intent(in) :: x + logical :: res + end function s_vect_is_asb + end interface + + interface + module subroutine s_vect_set_state(n,x) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine s_vect_set_state + end interface + + interface + module subroutine s_vect_set_null(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_set_null + end interface + + interface + module subroutine s_vect_set_bld(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_set_bld + end interface + + interface + module subroutine s_vect_set_upd(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_set_upd + end interface + + interface + module subroutine s_vect_set_asb(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_set_asb + end interface + + interface + module function s_vect_get_nrmv(x) result(res) + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_vect_get_nrmv + end interface + + interface + module subroutine s_vect_set_nrmv(x,val) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine s_vect_set_nrmv + end interface + + interface + module function s_vect_is_remote_build(x) result(res) + class(psb_s_vect_type), intent(in) :: x + logical :: res + end function s_vect_is_remote_build + end interface + + interface + module subroutine s_vect_set_remote_build(x,val) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine s_vect_set_remote_build + end interface + interface psb_set_vect_default - module procedure psb_s_set_vect_default - end interface psb_set_vect_default + module subroutine psb_s_set_vect_default(v) + class(psb_s_base_vect_type), intent(in) :: v + end subroutine psb_s_set_vect_default + end interface interface psb_get_vect_default - module procedure psb_s_get_vect_default - end interface psb_get_vect_default - + module function psb_s_get_vect_default(v) result(res) + class(psb_s_vect_type), intent(in) :: v + class(psb_s_base_vect_type), pointer :: res + end function psb_s_get_vect_default + end interface + + interface + module subroutine psb_s_clear_vect_default() + end subroutine psb_s_clear_vect_default + end interface + + interface + module function psb_s_get_base_vect_default() result(res) + class(psb_s_base_vect_type), pointer :: res + end function psb_s_get_base_vect_default + end interface + + interface + module subroutine s_vect_clone(x,y,info) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_clone + end interface + + interface + module subroutine s_vect_bld_x(x,invect,mold,scratch) + real(psb_spk_), intent(in) :: invect(:) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine s_vect_bld_x + end interface + + interface + module subroutine s_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine s_vect_bld_mn + end interface + + interface + module subroutine s_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine s_vect_bld_en + end interface + + interface + module function s_vect_get_vect(x,n) result(res) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function s_vect_get_vect + end interface + + interface + module subroutine s_vect_set_scal(x,val,first,last) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine s_vect_set_scal + end interface + + interface + module subroutine s_vect_set_vect(x,val,first,last) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine s_vect_set_vect + end interface + + interface + module subroutine s_vect_check_addr(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_check_addr + end interface + + interface + module function s_vect_get_nrows(x) result(res) + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_vect_get_nrows + end interface + + interface + module function s_vect_sizeof(x) result(res) + class(psb_s_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function s_vect_sizeof + end interface + + interface + module function s_vect_get_fmt(x) result(res) + class(psb_s_vect_type), intent(in) :: x + character(len=5) :: res + end function s_vect_get_fmt + end interface + + interface + module subroutine s_vect_all(n, x, info, mold) + 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 + end subroutine s_vect_all + end interface + + interface + module subroutine s_vect_reinit(x, info, clear) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine s_vect_reinit + end interface + + interface + module subroutine s_vect_reall(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_reall + end interface + + interface + module subroutine s_vect_zero(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_zero + end interface + + interface + module subroutine s_vect_asb(n, x, info, scratch) + integer(psb_ipk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine s_vect_asb + end interface + + interface + module subroutine s_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_vect_type) :: x + end subroutine s_vect_gthab + end interface + + interface + module subroutine s_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_vect_type) :: x + end subroutine s_vect_gthzv + end interface + + interface + module subroutine s_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_vect_type) :: y + end subroutine s_vect_sctb + end interface + + interface + module subroutine s_vect_free(x, info) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_free + end interface + + interface + module subroutine s_vect_ins_a(n,irl,val,x,maxr,info) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_ins_a + end interface + + interface + module subroutine s_vect_ins_v(n,irl,val,x,maxr,info) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_s_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_ins_v + end interface + + interface + module subroutine s_vect_cnv(x,mold) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + class(psb_s_base_vect_type), allocatable :: tmp + end subroutine s_vect_cnv + end interface + + interface + module subroutine s_vect_sync(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_sync + end interface + + interface + module subroutine s_vect_set_sync(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_set_sync + end interface + + interface + module subroutine s_vect_set_host(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_set_host + end interface + + interface + module subroutine s_vect_set_dev(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_set_dev + end interface + + interface + module function s_vect_is_sync(x) result(res) + logical :: res + class(psb_s_vect_type), intent(inout) :: x + end function s_vect_is_sync + end interface + + interface + module function s_vect_is_host(x) result(res) + logical :: res + class(psb_s_vect_type), intent(inout) :: x + end function s_vect_is_host + end interface + + interface + module function s_vect_is_dev(x) result(res) + logical :: res + class(psb_s_vect_type), intent(inout) :: x + end function s_vect_is_dev + end interface + + + interface + module function s_vect_get_entry(x,index) result(res) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: res + end function s_vect_get_entry + end interface + + interface + module subroutine s_vect_set_entry(x,index,val) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + end subroutine s_vect_set_entry + end interface + + interface + module function s_vect_dot_v(n,x,y) result(res) + class(psb_s_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_vect_dot_v + end interface + + interface + module function s_vect_dot_a(n,x,y) result(res) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_vect_dot_a + end interface + + interface + module subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_axpby_v + end interface + + interface + module subroutine s_vect_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_axpby_v2 + end interface + + interface + module subroutine s_vect_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_axpby_a + end interface + + interface + module subroutine s_vect_axpby_a2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_axpby_a2 + end interface + + interface + module subroutine s_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_upd_xyz + end interface + + interface + module subroutine s_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + class(psb_s_vect_type), intent(inout) :: w + real(psb_spk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_xyzw + end interface + + interface + module subroutine s_vect_mlt_v(x, y, info) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_mlt_v + end interface + + interface + module subroutine s_vect_mlt_a(x, y, info) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_mlt_a + end interface + + interface + module subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: y(:) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_mlt_a_2 + end interface + + interface + module subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_spk_), intent(in) :: alpha,beta + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine s_vect_mlt_v_2 + end interface + + interface + module subroutine s_vect_mlt_av(alpha,x,y,beta,z,info) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_mlt_av + end interface + + interface + module subroutine s_vect_mlt_va(alpha,x,y,beta,z,info) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_mlt_va + end interface + + interface + module subroutine s_vect_div_v(x, y, info) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_div_v + end interface + + interface + module subroutine s_vect_div_v2( x, y, z, info) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_div_v2 + end interface + + interface + module subroutine s_vect_div_v_check(x, y, info, flag) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_vect_div_v_check + end interface + + interface + module subroutine s_vect_div_v2_check(x, y, z, info, flag) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_vect_div_v2_check + end interface + + interface + module subroutine s_vect_div_a2(x, y, z, info) + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_div_a2 + end interface + + interface + module subroutine s_vect_div_a2_check(x, y, z, info,flag) + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_vect_div_a2_check + end interface + + interface + module subroutine s_vect_inv_v(x, y, info) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_inv_v + end interface + + interface + module subroutine s_vect_inv_v_check(x, y, info, flag) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_vect_inv_v_check + end interface + + interface + module subroutine s_vect_inv_a2(x, y, info) + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_inv_a2 + end interface + + interface + module subroutine s_vect_inv_a2_check(x, y, info,flag) + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_vect_inv_a2_check + end interface + + interface + module subroutine s_vect_acmp_a2(x,c,z,info) + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_acmp_a2 + end interface + + interface + module subroutine s_vect_acmp_v2(x,c,z,info) + real(psb_spk_), intent(in) :: c + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_acmp_v2 + end interface + + interface + module subroutine s_vect_scal(alpha, x) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent (in) :: alpha + end subroutine s_vect_scal + end interface + + interface + module subroutine s_vect_absval1(x) + class(psb_s_vect_type), intent(inout) :: x + end subroutine s_vect_absval1 + end interface + + interface + module subroutine s_vect_absval2(x,y) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + end subroutine s_vect_absval2 + end interface + + interface + module function s_vect_nrm2(n,x) result(res) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_vect_nrm2 + end interface + + interface + module function s_vect_nrm2_weight(n,x,w,aux) result(res) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: w + class(psb_s_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_vect_nrm2_weight + end interface + + interface + module function s_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: w + class(psb_s_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_s_vect_type), intent(inout), optional :: aux + end function s_vect_nrm2_weight_mask + end interface + + interface + module function s_vect_amax(n,x) result(res) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_vect_amax + end interface + + interface + module function s_vect_min(n,x) result(res) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_vect_min + end interface + + interface + module function s_vect_asum(n,x) result(res) + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_vect_asum + end interface + + + interface + module subroutine s_vect_mask_a(c,x,m,t,info) + real(psb_spk_), intent(inout) :: c(:) + real(psb_spk_), intent(inout) :: x(:) + logical, intent(out) :: t; + class(psb_s_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_mask_a + end interface + + interface + module subroutine s_vect_mask_v(c,x,m,t,info) + class(psb_s_vect_type), intent(inout) :: c + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: m + logical, intent(out) :: t; + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_mask_v + end interface + + interface + module function s_vect_minquotient_v(x, y, info) result(z) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + end function s_vect_minquotient_v + end interface + + interface + module function s_vect_minquotient_a2(x, y, info) result(z) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: z + end function s_vect_minquotient_a2 + end interface + + + + interface + module subroutine s_vect_addconst_a2(x,b,z,info) + real(psb_spk_), intent(in) :: b + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_addconst_a2 + end interface + + interface + module subroutine s_vect_addconst_v2(x,b,z,info) + real(psb_spk_), intent(in) :: b + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_vect_addconst_v2 + end interface contains - function s_vect_get_dupl(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_dupl() - else - res = psb_dupl_null_ - end if - end function s_vect_get_dupl - - subroutine s_vect_set_dupl(x,val) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_dupl(val) - else - call x%v%set_dupl(psb_dupl_def_) - end if - end if - end subroutine s_vect_set_dupl - - function s_vect_get_ncfs(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_ncfs() - else - res = 0 - end if - end function s_vect_get_ncfs - - subroutine s_vect_set_ncfs(x,val) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_ncfs(val) - else - call x%v%set_ncfs(0) - end if - end if - end subroutine s_vect_set_ncfs - - function s_vect_get_state(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_state() - else - res = psb_vect_null_ - end if - end function s_vect_get_state - - function s_vect_is_null(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_null_) - end function s_vect_is_null - - function s_vect_is_bld(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_bld_) - end function s_vect_is_bld - - function s_vect_is_upd(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_upd_) - end function s_vect_is_upd - - function s_vect_is_asb(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_asb_) - end function s_vect_is_asb - - subroutine s_vect_set_state(n,x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - if (allocated(x%v)) then - call x%v%set_state(n) - end if - end subroutine s_vect_set_state - - - subroutine s_vect_set_null(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_null_) - end subroutine s_vect_set_null - - subroutine s_vect_set_bld(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_bld_) - end subroutine s_vect_set_bld - - subroutine s_vect_set_upd(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_upd_) - end subroutine s_vect_set_upd - - subroutine s_vect_set_asb(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_asb_) - end subroutine s_vect_set_asb - - 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 - class(psb_s_vect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function s_vect_is_remote_build - - subroutine s_vect_set_remote_build(x,val) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine s_vect_set_remote_build - - subroutine psb_s_set_vect_default(v) - implicit none - class(psb_s_base_vect_type), intent(in) :: v - - if (allocated(psb_s_base_vect_default)) then - deallocate(psb_s_base_vect_default) - end if - allocate(psb_s_base_vect_default, mold=v) - - end subroutine psb_s_set_vect_default - - function psb_s_get_vect_default(v) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: v - class(psb_s_base_vect_type), pointer :: res - - res => psb_s_get_base_vect_default() - - end function psb_s_get_vect_default - - subroutine psb_s_clear_vect_default() - implicit none - - if (allocated(psb_s_base_vect_default)) then - deallocate(psb_s_base_vect_default) - end if - - end subroutine psb_s_clear_vect_default - - function psb_s_get_base_vect_default() result(res) - implicit none - class(psb_s_base_vect_type), pointer :: res - - if (.not.allocated(psb_s_base_vect_default)) then - allocate(psb_s_base_vect_type :: psb_s_base_vect_default) - end if - - res => psb_s_base_vect_default - - end function psb_s_get_base_vect_default - - subroutine s_vect_clone(x,y,info) - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - ! - ! Using sourced allocation here creates - ! problems with handling of memory allocated - ! elsewhere (e.g. accelerators), hence delegation - ! to %bld method - ! - call y%bld(x%get_vect(),mold=x%v) - end if - end subroutine s_vect_clone - - subroutine s_vect_bld_x(x,invect,mold,scratch) - real(psb_spk_), intent(in) :: invect(:) - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) - - end subroutine s_vect_bld_x - - - subroutine s_vect_bld_mn(x,n,mold,scratch) - integer(psb_mpk_), intent(in) :: n - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - class(psb_s_base_vect_type), pointer :: mld - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine s_vect_bld_mn - - subroutine s_vect_bld_en(x,n,mold,scratch) - integer(psb_epk_), intent(in) :: n - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine s_vect_bld_en - - function s_vect_get_vect(x,n) result(res) - class(psb_s_vect_type), intent(inout) :: x - real(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - - if (allocated(x%v)) then - res = x%v%get_vect(n) - end if - end function s_vect_get_vect - - subroutine s_vect_set_scal(x,val,first,last) - class(psb_s_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine s_vect_set_scal - - subroutine s_vect_set_vect(x,val,first,last) - class(psb_s_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine s_vect_set_vect - - subroutine s_vect_check_addr(x) - class(psb_s_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%check_addr() - - end subroutine s_vect_check_addr - function constructor(x) result(this) real(psb_spk_) :: x(:) type(psb_s_vect_type) :: this @@ -573,984 +995,8 @@ contains end function size_const - function s_vect_get_nrows(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function s_vect_get_nrows - - function s_vect_sizeof(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function s_vect_sizeof - - function s_vect_get_fmt(x) result(res) - implicit none - class(psb_s_vect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function s_vect_get_fmt - - 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 - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_s_base_vect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(n,info) - else - info = psb_err_alloc_dealloc_ - end if - call x%set_bld() - end subroutine s_vect_all - - subroutine s_vect_reinit(x, info, clear) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - - if (allocated(x%v)) call x%v%reinit(info,clear) - call x%set_upd() - - end subroutine s_vect_reinit - - subroutine s_vect_reall(n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(n,info) - if (info == 0) & - & call x%asb(n,info) - - end subroutine s_vect_reall - - subroutine s_vect_zero(x) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine s_vect_zero - - subroutine s_vect_asb(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - if (allocated(x%v)) then - call x%v%asb(n,info,scratch=scratch) - call x%set_asb() - end if - end subroutine s_vect_asb - - subroutine s_vect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: alpha, beta, y(:) - class(psb_s_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine s_vect_gthab - - subroutine s_vect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: y(:) - class(psb_s_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine s_vect_gthzv - - subroutine s_vect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: beta, x(:) - class(psb_s_vect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine s_vect_sctb - - subroutine s_vect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine s_vect_free - - subroutine s_vect_ins_a(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine s_vect_ins_a - - subroutine s_vect_ins_v(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - 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, 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,maxr,info) - - end subroutine s_vect_ins_v - - - subroutine s_vect_cnv(x,mold) - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(in), optional :: mold - class(psb_s_base_vect_type), allocatable :: tmp - - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info,mold=psb_s_get_base_vect_default()) - end if - if (allocated(x%v)) then - if (allocated(x%v%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%base_cpy(tmp) - call x%v%free(info) - endif - end if - call move_alloc(tmp,x%v) - - end subroutine s_vect_cnv - - - subroutine s_vect_sync(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine s_vect_sync - - subroutine s_vect_set_sync(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_sync() - - end subroutine s_vect_set_sync - - subroutine s_vect_set_host(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_host() - - end subroutine s_vect_set_host - - subroutine s_vect_set_dev(x) - implicit none - class(psb_s_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_dev() - - end subroutine s_vect_set_dev - - function s_vect_is_sync(x) result(res) - implicit none - logical :: res - class(psb_s_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_sync() - - end function s_vect_is_sync - - function s_vect_is_host(x) result(res) - implicit none - logical :: res - class(psb_s_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_host() - - end function s_vect_is_host - - function s_vect_is_dev(x) result(res) - implicit none - logical :: res - class(psb_s_vect_type), intent(inout) :: x - - res = .false. - if (allocated(x%v)) & - & res = x%v%is_dev() - - end function s_vect_is_dev - - - function s_vect_get_entry(x,index) result(res) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_spk_) :: res - res = szero - if (allocated(x%v)) res = x%v%get_entry(index) - end function s_vect_get_entry - - subroutine s_vect_set_entry(x,index,val) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_spk_) :: val - - if (allocated(x%v)) call x%v%set_entry(index,val) - end subroutine s_vect_set_entry - - function s_vect_dot_v(n,x,y) result(res) - implicit none - class(psb_s_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - res = szero - if (allocated(x%v).and.allocated(y%v)) & - & res = x%v%dot(n,y%v) - - end function s_vect_dot_v - - function s_vect_dot_a(n,x,y) result(res) - implicit none - class(psb_s_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - res = szero - if (allocated(x%v)) & - & res = x%v%dot_a(n,y) - - end function s_vect_dot_a - - subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call y%v%axpby(m,alpha,x%v,beta,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine s_vect_axpby_v - - subroutine s_vect_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - class(psb_s_vect_type), intent(inout) :: z - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call z%v%axpby(m,alpha,x%v,beta,y%v,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine s_vect_axpby_v2 - - subroutine s_vect_axpby_a(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - real(psb_spk_), intent(in) :: x(:) - class(psb_s_vect_type), intent(inout) :: y - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(y%v)) & - & call y%v%axpby(m,alpha,x,beta,info) - - end subroutine s_vect_axpby_a - - subroutine s_vect_axpby_a2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - real(psb_spk_), intent(in) :: x(:) - real(psb_spk_), intent(in) :: y(:) - class(psb_s_vect_type), intent(inout) :: z - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - & call z%v%axpby(m,alpha,x,beta,y,info) - - end subroutine s_vect_axpby_a2 - - subroutine s_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - class(psb_s_vect_type), intent(inout) :: z - real(psb_spk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) - - end subroutine s_vect_upd_xyz - - subroutine s_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - class(psb_s_vect_type), intent(inout) :: z - class(psb_s_vect_type), intent(inout) :: w - real(psb_spk_), intent (in) :: a, b, c, d, e, f - integer(psb_ipk_), intent(out) :: info - - if (allocated(w%v)) & - call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) - - end subroutine s_vect_xyzw - - - subroutine s_vect_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%mlt(x%v,info) - - end subroutine s_vect_mlt_v - - subroutine s_vect_mlt_a(x, y, info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: x(:) - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - - info = 0 - if (allocated(y%v)) & - & call y%v%mlt(x,info) - - end subroutine s_vect_mlt_a - - - subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: alpha,beta - real(psb_spk_), intent(in) :: y(:) - real(psb_spk_), intent(in) :: x(:) - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%mlt(alpha,x,y,beta,info) - - end subroutine s_vect_mlt_a_2 - - subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: alpha,beta - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.& - & allocated(z%v)) & - & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) - - end subroutine s_vect_mlt_v_2 - - subroutine s_vect_mlt_av(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: alpha,beta - real(psb_spk_), intent(in) :: x(:) - class(psb_s_vect_type), intent(inout) :: y - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v).and.allocated(y%v)) & - & call z%v%mlt(alpha,x,y%v,beta,info) - - end subroutine s_vect_mlt_av - - subroutine s_vect_mlt_va(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: alpha,beta - real(psb_spk_), intent(in) :: y(:) - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - - if (allocated(z%v).and.allocated(x%v)) & - & call z%v%mlt(alpha,x%v,y,beta,info) - - end subroutine s_vect_mlt_va - - subroutine s_vect_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info) - - end subroutine s_vect_div_v - - subroutine s_vect_div_v2( x, y, z, info) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info) - - end subroutine s_vect_div_v2 - - subroutine s_vect_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info,flag) - - end subroutine s_vect_div_v_check - - subroutine s_vect_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info,flag) - - end subroutine s_vect_div_v2_check - - subroutine s_vect_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: x(:) - real(psb_spk_), intent(in) :: y(:) - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info) - - end subroutine s_vect_div_a2 - - subroutine s_vect_div_a2_check(x, y, z, info,flag) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: x(:) - real(psb_spk_), intent(in) :: y(:) - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info,flag) - - end subroutine s_vect_div_a2_check - - subroutine s_vect_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info) - - end subroutine s_vect_inv_v - - subroutine s_vect_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info,flag) - - end subroutine s_vect_inv_v_check - - subroutine s_vect_inv_a2(x, y, info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(inout) :: x(:) - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info) - - end subroutine s_vect_inv_a2 - - subroutine s_vect_inv_a2_check(x, y, info,flag) - use psi_serial_mod - implicit none - real(psb_spk_), intent(inout) :: x(:) - class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info,flag) - - end subroutine s_vect_inv_a2_check - - subroutine s_vect_acmp_a2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: c - real(psb_spk_), intent(inout) :: x(:) - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%acmp(x,c,info) - - end subroutine s_vect_acmp_a2 - - subroutine s_vect_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: c - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%acmp(x%v,c,info) - - end subroutine s_vect_acmp_v2 - - subroutine s_vect_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - real(psb_spk_), intent (in) :: alpha - - if (allocated(x%v)) call x%v%scal(alpha) - - end subroutine s_vect_scal - - subroutine s_vect_absval1(x) - class(psb_s_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%absval() - - end subroutine s_vect_absval1 - - subroutine s_vect_absval2(x,y) - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - - if (allocated(x%v)) then - if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) - call x%v%absval(y%v) - end if - end subroutine s_vect_absval2 - - function s_vect_nrm2(n,x) result(res) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - if (allocated(x%v)) then - res = x%v%nrm2(n) - else - res = szero - end if - - end function s_vect_nrm2 - - function s_vect_nrm2_weight(n,x,w,aux) result(res) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: w - class(psb_s_vect_type), intent(inout), optional :: aux - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_) :: info - - ! Temp vectors - type(psb_s_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,sone,w%v%v,szero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -sone - return - end if - - if (allocated(x%v)) then - if (.not.present(aux)) then - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = szero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function s_vect_nrm2_weight - - function s_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: w - class(psb_s_vect_type), intent(inout) :: id - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_), intent(out) :: info - class(psb_s_vect_type), intent(inout), optional :: aux - - ! Temp vectors - type(psb_s_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,sone,w%v%v,szero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -sone - return - end if - - - if (allocated(x%v).and.allocated(id%v)) then - if (.not.present(aux)) then - where( abs(id%v%v) <= szero) wtemp%v%v = szero - call wtemp%set_host() - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - where( abs(id%v%v) <= szero) aux%v%v = szero - call aux%set_host() - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = szero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function s_vect_nrm2_weight_mask - - function s_vect_amax(n,x) result(res) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - if (allocated(x%v)) then - res = x%v%amax(n) - else - res = szero - end if - - end function s_vect_amax - - function s_vect_min(n,x) result(res) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - if (allocated(x%v)) then - res = x%v%minreal(n) - else - res = HUGE(szero) - end if - - end function s_vect_min - - function s_vect_asum(n,x) result(res) - implicit none - class(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - - if (allocated(x%v)) then - res = x%v%asum(n) - else - res = szero - end if - - end function s_vect_asum - - - subroutine s_vect_mask_a(c,x,m,t,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(inout) :: c(:) - real(psb_spk_), intent(inout) :: x(:) - logical, intent(out) :: t; - class(psb_s_vect_type), intent(inout) :: m - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(m%v)) & - & call m%mask(c,x,t,info) - - end subroutine s_vect_mask_a - - subroutine s_vect_mask_v(c,x,m,t,info) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: c - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: m - logical, intent(out) :: t; - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(c%v)) & - & call m%v%mask(x%v,c%v,t,info) - - end subroutine s_vect_mask_v - - function s_vect_minquotient_v(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: y - real(psb_spk_) :: z - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & z = x%v%minquotient(y%v,info) - - end function s_vect_minquotient_v - - function s_vect_minquotient_a2(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_s_vect_type), intent(inout) :: x - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: z - - info = 0 - z = x%v%minquotient(y,info) - - end function s_vect_minquotient_a2 - - - - subroutine s_vect_addconst_a2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: b - real(psb_spk_), intent(inout) :: x(:) - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%addconst(x,b,info) - - end subroutine s_vect_addconst_a2 - - subroutine s_vect_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: b - class(psb_s_vect_type), intent(inout) :: x - class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%addconst(x%v,b,info) - - end subroutine s_vect_addconst_v2 - end module psb_s_vect_mod - module psb_s_multivect_mod use psb_s_base_multivect_mod @@ -1631,410 +1077,239 @@ module psb_s_multivect_mod class(psb_s_base_multivect_type), allocatable, target,& & save, private :: psb_s_base_multivect_default - interface psb_set_multivect_default - module procedure psb_s_set_multivect_default - end interface psb_set_multivect_default - - interface psb_get_multivect_default - module procedure psb_s_get_multivect_default - end interface psb_get_multivect_default - - -contains - - function s_mvect_get_dupl(x) result(res) - implicit none - class(psb_s_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function s_mvect_get_dupl - - subroutine s_mvect_set_dupl(x,val) - implicit none - class(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ - end if - end subroutine s_mvect_set_dupl - - - function s_mvect_is_remote_build(x) result(res) - implicit none - class(psb_s_multivect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function s_mvect_is_remote_build - - subroutine s_mvect_set_remote_build(x,val) - implicit none - class(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine s_mvect_set_remote_build - - - subroutine psb_s_set_multivect_default(v) - implicit none - class(psb_s_base_multivect_type), intent(in) :: v - - if (allocated(psb_s_base_multivect_default)) then - deallocate(psb_s_base_multivect_default) - end if - allocate(psb_s_base_multivect_default, mold=v) - - end subroutine psb_s_set_multivect_default - - function psb_s_get_multivect_default(v) result(res) - implicit none - class(psb_s_multivect_type), intent(in) :: v - class(psb_s_base_multivect_type), pointer :: res - - res => psb_s_get_base_multivect_default() - - end function psb_s_get_multivect_default - - - function psb_s_get_base_multivect_default() result(res) - implicit none - class(psb_s_base_multivect_type), pointer :: res - - if (.not.allocated(psb_s_base_multivect_default)) then - allocate(psb_s_base_multivect_type :: psb_s_base_multivect_default) - end if - - res => psb_s_base_multivect_default - - end function psb_s_get_base_multivect_default - - - subroutine s_mvect_clone(x,y,info) - implicit none - class(psb_s_multivect_type), intent(inout) :: x - class(psb_s_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - call y%bld_x(x%get_vect(),mold=x%v) - end if - end subroutine s_mvect_clone - - subroutine s_mvect_bld_x(x,invect,mold) - real(psb_spk_), intent(in) :: invect(:,:) - class(psb_s_multivect_type), intent(out) :: x - class(psb_s_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - class(psb_s_base_multivect_type), pointer :: mld - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect) - - end subroutine s_mvect_bld_x - - - subroutine s_mvect_bld_n(x,m,n,mold,scratch) - integer(psb_ipk_), intent(in) :: m,n - class(psb_s_multivect_type), intent(out) :: x - class(psb_s_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) - endif - if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) - - end subroutine s_mvect_bld_n - - function s_mvect_get_vect(x) result(res) - class(psb_s_multivect_type), intent(inout) :: x - real(psb_spk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - res = x%v%get_vect() - end if - end function s_mvect_get_vect - - subroutine s_mvect_set_scal(x,val) - class(psb_s_multivect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine s_mvect_set_scal - - subroutine s_mvect_set_vect(x,val) - class(psb_s_multivect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val(:,:) - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine s_mvect_set_vect - - - function constructor(x) result(this) - real(psb_spk_) :: x(:,:) - type(psb_s_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_x(x) - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) - - end function constructor - - - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_s_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_n(m,n) - call this%asb(m,n,info) - - end function size_const - - function s_mvect_get_nrows(x) result(res) - implicit none - class(psb_s_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function s_mvect_get_nrows - - function s_mvect_get_ncols(x) result(res) - implicit none - class(psb_s_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_ncols() - end function s_mvect_get_ncols - - function s_mvect_sizeof(x) result(res) - implicit none - class(psb_s_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function s_mvect_sizeof - - function s_mvect_get_fmt(x) result(res) - implicit none - class(psb_s_multivect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function s_mvect_get_fmt - - subroutine s_mvect_all(m,n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_s_multivect_type), intent(out) :: x - class(psb_s_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_s_base_multivect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(m,n,info) - else - info = psb_err_alloc_dealloc_ - end if - - end subroutine s_mvect_all - - subroutine s_mvect_reall(m,n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(m,n,info) - if (info == 0) & - & call x%asb(m,n,info) - - end subroutine s_mvect_reall - - subroutine s_mvect_zero(x) - use psi_serial_mod - implicit none - class(psb_s_multivect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine s_mvect_zero - - subroutine s_mvect_asb(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) & - & call x%v%asb(m,n,info) - - end subroutine s_mvect_asb - - subroutine s_mvect_sync(x) - implicit none - class(psb_s_multivect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine s_mvect_sync - - subroutine s_mvect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: alpha, beta, y(:) - class(psb_s_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine s_mvect_gthab - - subroutine s_mvect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: y(:) - class(psb_s_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine s_mvect_gthzv - - subroutine s_mvect_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_spk_) :: y(:) - class(psb_s_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(i,n,idx,y) - - end subroutine s_mvect_gthzv_x - - subroutine s_mvect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: beta, x(:) - class(psb_s_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine s_mvect_sctb - - subroutine s_mvect_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_spk_) :: beta, x(:) - class(psb_s_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(i,n,idx,x,beta) - - end subroutine s_mvect_sctb_x - - subroutine s_mvect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine s_mvect_free - - subroutine s_mvect_ins(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine s_mvect_ins - - - subroutine s_mvect_cnv(x,mold) - class(psb_s_multivect_type), intent(inout) :: x - class(psb_s_base_multivect_type), intent(in), optional :: mold - class(psb_s_base_multivect_type), allocatable :: tmp - integer(psb_ipk_) :: info - - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info, mold=psb_s_get_base_multivect_default()) - endif - if (allocated(x%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%free(info) - end if - call move_alloc(tmp,x%v) - end subroutine s_mvect_cnv - - -!!$ function s_mvect_dot_v(n,x,y) result(res) + interface + module function s_mvect_get_dupl(x) result(res) + class(psb_s_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_mvect_get_dupl + end interface + + interface + module subroutine s_mvect_set_dupl(x,val) + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine s_mvect_set_dupl + end interface + + interface + module function s_mvect_is_remote_build(x) result(res) + class(psb_s_multivect_type), intent(in) :: x + logical :: res + end function s_mvect_is_remote_build + end interface + + interface + module subroutine s_mvect_set_remote_build(x,val) + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine s_mvect_set_remote_build + end interface + + interface + module subroutine psb_s_set_multivect_default(v) + class(psb_s_base_multivect_type), intent(in) :: v + end subroutine psb_s_set_multivect_default + end interface + + interface + module function psb_s_get_multivect_default(v) result(res) + class(psb_s_multivect_type), intent(in) :: v + class(psb_s_base_multivect_type), pointer :: res + end function psb_s_get_multivect_default + end interface + + interface + module function psb_s_get_base_multivect_default() result(res) + class(psb_s_base_multivect_type), pointer :: res + end function psb_s_get_base_multivect_default + end interface + + interface + module subroutine s_mvect_clone(x,y,info) + class(psb_s_multivect_type), intent(inout) :: x + class(psb_s_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_mvect_clone + end interface + + interface + module subroutine s_mvect_bld_x(x,invect,mold) + real(psb_spk_), intent(in) :: invect(:,:) + class(psb_s_multivect_type), intent(out) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + end subroutine s_mvect_bld_x + end interface + + + interface + module subroutine s_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(out) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine s_mvect_bld_n + end interface + + interface + module function s_mvect_get_vect(x) result(res) + class(psb_s_multivect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:,:) + end function s_mvect_get_vect + end interface + + interface + module subroutine s_mvect_set_scal(x,val) + class(psb_s_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + end subroutine s_mvect_set_scal + end interface + + interface + module subroutine s_mvect_set_vect(x,val) + class(psb_s_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:,:) + end subroutine s_mvect_set_vect + end interface + + interface + module function s_mvect_get_nrows(x) result(res) + class(psb_s_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_mvect_get_nrows + end interface + + interface + module function s_mvect_get_ncols(x) result(res) + class(psb_s_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_mvect_get_ncols + end interface + + interface + module function s_mvect_sizeof(x) result(res) + class(psb_s_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function s_mvect_sizeof + end interface + + interface + module function s_mvect_get_fmt(x) result(res) + class(psb_s_multivect_type), intent(in) :: x + character(len=5) :: res + end function s_mvect_get_fmt + end interface + + interface + module subroutine s_mvect_all(m,n, x, info, mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(out) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + end subroutine s_mvect_all + end interface + + interface + module subroutine s_mvect_reall(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_mvect_reall + end interface + + interface + module subroutine s_mvect_zero(x) + class(psb_s_multivect_type), intent(inout) :: x + end subroutine s_mvect_zero + end interface + + interface + module subroutine s_mvect_asb(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_mvect_asb + end interface + + interface + module subroutine s_mvect_sync(x) + class(psb_s_multivect_type), intent(inout) :: x + end subroutine s_mvect_sync + end interface + + interface + module subroutine s_mvect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_multivect_type) :: x + end subroutine s_mvect_gthab + end interface + + interface + module subroutine s_mvect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_multivect_type) :: x + end subroutine s_mvect_gthzv + end interface + + interface + module subroutine s_mvect_gthzv_x(i,n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: y(:) + class(psb_s_multivect_type) :: x + end subroutine s_mvect_gthzv_x + end interface + + interface + module subroutine s_mvect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_multivect_type) :: y + end subroutine s_mvect_sctb + end interface + + interface + module subroutine s_mvect_sctb_x(i,n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta, x(:) + class(psb_s_multivect_type) :: y + end subroutine s_mvect_sctb_x + end interface + + interface + module subroutine s_mvect_free(x, info) + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_mvect_free + end interface + + interface + module subroutine s_mvect_ins(n,irl,val,x,maxr,info) + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine s_mvect_ins + end interface + + interface + module subroutine s_mvect_cnv(x,mold) + class(psb_s_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + end subroutine s_mvect_cnv + end interface + + +!!$ module function s_mvect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n @@ -2046,7 +1321,7 @@ contains !!$ !!$ end function s_mvect_dot_v !!$ -!!$ function s_mvect_dot_a(n,x,y) result(res) +!!$ module function s_mvect_dot_a(n,x,y) result(res) !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ real(psb_spk_), intent(in) :: y(:) @@ -2059,7 +1334,7 @@ contains !!$ !!$ end function s_mvect_dot_a !!$ -!!$ subroutine s_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ module subroutine s_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -2076,7 +1351,7 @@ contains !!$ !!$ end subroutine s_mvect_axpby_v !!$ -!!$ subroutine s_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ module subroutine s_mvect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -2091,7 +1366,7 @@ contains !!$ end subroutine s_mvect_axpby_a !!$ !!$ -!!$ subroutine s_mvect_mlt_v(x, y, info) +!!$ module subroutine s_mvect_mlt_v(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x @@ -2105,7 +1380,7 @@ contains !!$ !!$ end subroutine s_mvect_mlt_v !!$ -!!$ subroutine s_mvect_mlt_a(x, y, info) +!!$ module subroutine s_mvect_mlt_a(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_spk_), intent(in) :: x(:) @@ -2121,7 +1396,7 @@ contains !!$ end subroutine s_mvect_mlt_a !!$ !!$ -!!$ subroutine s_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ module subroutine s_mvect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta @@ -2137,7 +1412,7 @@ contains !!$ !!$ end subroutine s_mvect_mlt_a_2 !!$ -!!$ subroutine s_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ module subroutine s_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta @@ -2155,8 +1430,8 @@ contains !!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) !!$ !!$ end subroutine s_mvect_mlt_v_2 -!!$ -!!$ subroutine s_mvect_mlt_av(alpha,x,y,beta,z,info) + +!!$ module subroutine s_mvect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta @@ -2172,7 +1447,7 @@ contains !!$ !!$ end subroutine s_mvect_mlt_av !!$ -!!$ subroutine s_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ module subroutine s_mvect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta @@ -2189,7 +1464,7 @@ contains !!$ !!$ end subroutine s_mvect_mlt_va !!$ -!!$ subroutine s_mvect_scal(alpha, x) +!!$ module subroutine s_mvect_scal(alpha, x) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x @@ -2200,7 +1475,7 @@ contains !!$ end subroutine s_mvect_scal !!$ !!$ -!!$ function s_mvect_nrm2(n,x) result(res) +!!$ module function s_mvect_nrm2(n,x) result(res) !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2214,7 +1489,7 @@ contains !!$ !!$ end function s_mvect_nrm2 !!$ -!!$ function s_mvect_amax(n,x) result(res) +!!$ module function s_mvect_amax(n,x) result(res) !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2228,7 +1503,7 @@ contains !!$ !!$ end function s_mvect_amax !!$ -!!$ function s_mvect_asum(n,x) result(res) +!!$ module function s_mvect_asum(n,x) result(res) !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2242,5 +1517,26 @@ contains !!$ !!$ end function s_mvect_asum -end module psb_s_multivect_mod +contains + + function constructor(x) result(this) + real(psb_spk_) :: x(:,:) + type(psb_s_multivect_type) :: this + integer(psb_ipk_) :: info + call this%bld_x(x) + call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + + end function constructor + + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_s_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld_n(m,n) + call this%asb(m,n,info) + + end function size_const + +end module psb_s_multivect_mod diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 5fe51052..37d97052 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -188,363 +188,739 @@ module psb_z_vect_mod class(psb_z_base_vect_type), allocatable, target,& & save, private :: psb_z_base_vect_default + + interface + module function z_vect_get_dupl(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_vect_get_dupl + end interface + + interface + module subroutine z_vect_set_dupl(x,val) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine z_vect_set_dupl + end interface + + interface + module function z_vect_get_ncfs(x) result(res) + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_vect_get_ncfs + end interface + + interface + module subroutine z_vect_set_ncfs(x,val) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine z_vect_set_ncfs + end interface + + interface + module function z_vect_get_state(x) result(res) + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_vect_get_state + end interface + + interface + module function z_vect_is_null(x) result(res) + class(psb_z_vect_type), intent(in) :: x + logical :: res + end function z_vect_is_null + end interface + + interface + module function z_vect_is_bld(x) result(res) + class(psb_z_vect_type), intent(in) :: x + logical :: res + end function z_vect_is_bld + end interface + + interface + module function z_vect_is_upd(x) result(res) + class(psb_z_vect_type), intent(in) :: x + logical :: res + end function z_vect_is_upd + end interface + + interface + module function z_vect_is_asb(x) result(res) + class(psb_z_vect_type), intent(in) :: x + logical :: res + end function z_vect_is_asb + end interface + + interface + module subroutine z_vect_set_state(n,x) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine z_vect_set_state + end interface + + interface + module subroutine z_vect_set_null(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_set_null + end interface + + interface + module subroutine z_vect_set_bld(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_set_bld + end interface + + interface + module subroutine z_vect_set_upd(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_set_upd + end interface + + interface + module subroutine z_vect_set_asb(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_set_asb + end interface + + interface + module function z_vect_get_nrmv(x) result(res) + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_vect_get_nrmv + end interface + + interface + module subroutine z_vect_set_nrmv(x,val) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine z_vect_set_nrmv + end interface + + interface + module function z_vect_is_remote_build(x) result(res) + class(psb_z_vect_type), intent(in) :: x + logical :: res + end function z_vect_is_remote_build + end interface + + interface + module subroutine z_vect_set_remote_build(x,val) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine z_vect_set_remote_build + end interface + interface psb_set_vect_default - module procedure psb_z_set_vect_default - end interface psb_set_vect_default + module subroutine psb_z_set_vect_default(v) + class(psb_z_base_vect_type), intent(in) :: v + end subroutine psb_z_set_vect_default + end interface interface psb_get_vect_default - module procedure psb_z_get_vect_default - end interface psb_get_vect_default - + module function psb_z_get_vect_default(v) result(res) + class(psb_z_vect_type), intent(in) :: v + class(psb_z_base_vect_type), pointer :: res + end function psb_z_get_vect_default + end interface + + interface + module subroutine psb_z_clear_vect_default() + end subroutine psb_z_clear_vect_default + end interface + + interface + module function psb_z_get_base_vect_default() result(res) + class(psb_z_base_vect_type), pointer :: res + end function psb_z_get_base_vect_default + end interface + + interface + module subroutine z_vect_clone(x,y,info) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_clone + end interface + + interface + module subroutine z_vect_bld_x(x,invect,mold,scratch) + complex(psb_dpk_), intent(in) :: invect(:) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine z_vect_bld_x + end interface + + interface + module subroutine z_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine z_vect_bld_mn + end interface + + interface + module subroutine z_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine z_vect_bld_en + end interface + + interface + module function z_vect_get_vect(x,n) result(res) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function z_vect_get_vect + end interface + + interface + module subroutine z_vect_set_scal(x,val,first,last) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine z_vect_set_scal + end interface + + interface + module subroutine z_vect_set_vect(x,val,first,last) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine z_vect_set_vect + end interface + + interface + module subroutine z_vect_check_addr(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_check_addr + end interface + + interface + module function z_vect_get_nrows(x) result(res) + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_vect_get_nrows + end interface + + interface + module function z_vect_sizeof(x) result(res) + class(psb_z_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function z_vect_sizeof + end interface + + interface + module function z_vect_get_fmt(x) result(res) + class(psb_z_vect_type), intent(in) :: x + character(len=5) :: res + end function z_vect_get_fmt + end interface + + interface + module subroutine z_vect_all(n, x, info, mold) + 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 + end subroutine z_vect_all + end interface + + interface + module subroutine z_vect_reinit(x, info, clear) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine z_vect_reinit + end interface + + interface + module subroutine z_vect_reall(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_reall + end interface + + interface + module subroutine z_vect_zero(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_zero + end interface + + interface + module subroutine z_vect_asb(n, x, info, scratch) + integer(psb_ipk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine z_vect_asb + end interface + + interface + module subroutine z_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_vect_type) :: x + end subroutine z_vect_gthab + end interface + + interface + module subroutine z_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_vect_type) :: x + end subroutine z_vect_gthzv + end interface + + interface + module subroutine z_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_vect_type) :: y + end subroutine z_vect_sctb + end interface + + interface + module subroutine z_vect_free(x, info) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_free + end interface + + interface + module subroutine z_vect_ins_a(n,irl,val,x,maxr,info) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_ins_a + end interface + + interface + module subroutine z_vect_ins_v(n,irl,val,x,maxr,info) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_z_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_ins_v + end interface + + interface + module subroutine z_vect_cnv(x,mold) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + class(psb_z_base_vect_type), allocatable :: tmp + end subroutine z_vect_cnv + end interface + + interface + module subroutine z_vect_sync(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_sync + end interface + + interface + module subroutine z_vect_set_sync(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_set_sync + end interface + + interface + module subroutine z_vect_set_host(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_set_host + end interface + + interface + module subroutine z_vect_set_dev(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_set_dev + end interface + + interface + module function z_vect_is_sync(x) result(res) + logical :: res + class(psb_z_vect_type), intent(inout) :: x + end function z_vect_is_sync + end interface + + interface + module function z_vect_is_host(x) result(res) + logical :: res + class(psb_z_vect_type), intent(inout) :: x + end function z_vect_is_host + end interface + + interface + module function z_vect_is_dev(x) result(res) + logical :: res + class(psb_z_vect_type), intent(inout) :: x + end function z_vect_is_dev + end interface + + + interface + module function z_vect_get_entry(x,index) result(res) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: res + end function z_vect_get_entry + end interface + + interface + module subroutine z_vect_set_entry(x,index,val) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + end subroutine z_vect_set_entry + end interface + + interface + module function z_vect_dot_v(n,x,y) result(res) + class(psb_z_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + end function z_vect_dot_v + end interface + + interface + module function z_vect_dot_a(n,x,y) result(res) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + end function z_vect_dot_a + end interface + + interface + module subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_axpby_v + end interface + + interface + module subroutine z_vect_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_axpby_v2 + end interface + + interface + module subroutine z_vect_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_axpby_a + end interface + + interface + module subroutine z_vect_axpby_a2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_axpby_a2 + end interface + + interface + module subroutine z_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_upd_xyz + end interface + + interface + module subroutine z_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + class(psb_z_vect_type), intent(inout) :: w + complex(psb_dpk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_xyzw + end interface + + interface + module subroutine z_vect_mlt_v(x, y, info) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_mlt_v + end interface + + interface + module subroutine z_vect_mlt_a(x, y, info) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_mlt_a + end interface + + interface + module subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: y(:) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_mlt_a_2 + end interface + + interface + module subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_dpk_), intent(in) :: alpha,beta + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine z_vect_mlt_v_2 + end interface + + interface + module subroutine z_vect_mlt_av(alpha,x,y,beta,z,info) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_mlt_av + end interface + + interface + module subroutine z_vect_mlt_va(alpha,x,y,beta,z,info) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_mlt_va + end interface + + interface + module subroutine z_vect_div_v(x, y, info) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_div_v + end interface + + interface + module subroutine z_vect_div_v2( x, y, z, info) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_div_v2 + end interface + + interface + module subroutine z_vect_div_v_check(x, y, info, flag) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_vect_div_v_check + end interface + + interface + module subroutine z_vect_div_v2_check(x, y, z, info, flag) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_vect_div_v2_check + end interface + + interface + module subroutine z_vect_div_a2(x, y, z, info) + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_div_a2 + end interface + + interface + module subroutine z_vect_div_a2_check(x, y, z, info,flag) + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_vect_div_a2_check + end interface + + interface + module subroutine z_vect_inv_v(x, y, info) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_inv_v + end interface + + interface + module subroutine z_vect_inv_v_check(x, y, info, flag) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_vect_inv_v_check + end interface + + interface + module subroutine z_vect_inv_a2(x, y, info) + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_inv_a2 + end interface + + interface + module subroutine z_vect_inv_a2_check(x, y, info,flag) + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_vect_inv_a2_check + end interface + + interface + module subroutine z_vect_acmp_a2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_acmp_a2 + end interface + + interface + module subroutine z_vect_acmp_v2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_acmp_v2 + end interface + + interface + module subroutine z_vect_scal(alpha, x) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent (in) :: alpha + end subroutine z_vect_scal + end interface + + interface + module subroutine z_vect_absval1(x) + class(psb_z_vect_type), intent(inout) :: x + end subroutine z_vect_absval1 + end interface + + interface + module subroutine z_vect_absval2(x,y) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + end subroutine z_vect_absval2 + end interface + + interface + module function z_vect_nrm2(n,x) result(res) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function z_vect_nrm2 + end interface + + interface + module function z_vect_nrm2_weight(n,x,w,aux) result(res) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: w + class(psb_z_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function z_vect_nrm2_weight + end interface + + interface + module function z_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: w + class(psb_z_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_z_vect_type), intent(inout), optional :: aux + end function z_vect_nrm2_weight_mask + end interface + + interface + module function z_vect_amax(n,x) result(res) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function z_vect_amax + end interface + + + interface + module function z_vect_asum(n,x) result(res) + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function z_vect_asum + end interface + + + + interface + module subroutine z_vect_addconst_a2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_addconst_a2 + end interface + + interface + module subroutine z_vect_addconst_v2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_vect_addconst_v2 + end interface contains - function z_vect_get_dupl(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_dupl() - else - res = psb_dupl_null_ - end if - end function z_vect_get_dupl - - subroutine z_vect_set_dupl(x,val) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_dupl(val) - else - call x%v%set_dupl(psb_dupl_def_) - end if - end if - end subroutine z_vect_set_dupl - - function z_vect_get_ncfs(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_ncfs() - else - res = 0 - end if - end function z_vect_get_ncfs - - subroutine z_vect_set_ncfs(x,val) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (allocated(x%v)) then - if (present(val)) then - call x%v%set_ncfs(val) - else - call x%v%set_ncfs(0) - end if - end if - end subroutine z_vect_set_ncfs - - function z_vect_get_state(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - if (allocated(x%v)) then - res = x%v%get_state() - else - res = psb_vect_null_ - end if - end function z_vect_get_state - - function z_vect_is_null(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_null_) - end function z_vect_is_null - - function z_vect_is_bld(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_bld_) - end function z_vect_is_bld - - function z_vect_is_upd(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_upd_) - end function z_vect_is_upd - - function z_vect_is_asb(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - logical :: res - res = (x%get_state() == psb_vect_asb_) - end function z_vect_is_asb - - subroutine z_vect_set_state(n,x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - if (allocated(x%v)) then - call x%v%set_state(n) - end if - end subroutine z_vect_set_state - - - subroutine z_vect_set_null(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_null_) - end subroutine z_vect_set_null - - subroutine z_vect_set_bld(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_bld_) - end subroutine z_vect_set_bld - - subroutine z_vect_set_upd(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_upd_) - end subroutine z_vect_set_upd - - subroutine z_vect_set_asb(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - call x%set_state(psb_vect_asb_) - end subroutine z_vect_set_asb - - 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 - class(psb_z_vect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function z_vect_is_remote_build - - subroutine z_vect_set_remote_build(x,val) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine z_vect_set_remote_build - - subroutine psb_z_set_vect_default(v) - implicit none - class(psb_z_base_vect_type), intent(in) :: v - - if (allocated(psb_z_base_vect_default)) then - deallocate(psb_z_base_vect_default) - end if - allocate(psb_z_base_vect_default, mold=v) - - end subroutine psb_z_set_vect_default - - function psb_z_get_vect_default(v) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: v - class(psb_z_base_vect_type), pointer :: res - - res => psb_z_get_base_vect_default() - - end function psb_z_get_vect_default - - subroutine psb_z_clear_vect_default() - implicit none - - if (allocated(psb_z_base_vect_default)) then - deallocate(psb_z_base_vect_default) - end if - - end subroutine psb_z_clear_vect_default - - function psb_z_get_base_vect_default() result(res) - implicit none - class(psb_z_base_vect_type), pointer :: res - - if (.not.allocated(psb_z_base_vect_default)) then - allocate(psb_z_base_vect_type :: psb_z_base_vect_default) - end if - - res => psb_z_base_vect_default - - end function psb_z_get_base_vect_default - - subroutine z_vect_clone(x,y,info) - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - ! - ! Using sourced allocation here creates - ! problems with handling of memory allocated - ! elsewhere (e.g. accelerators), hence delegation - ! to %bld method - ! - call y%bld(x%get_vect(),mold=x%v) - end if - end subroutine z_vect_clone - - subroutine z_vect_bld_x(x,invect,mold,scratch) - complex(psb_dpk_), intent(in) :: invect(:) - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) - - end subroutine z_vect_bld_x - - - subroutine z_vect_bld_mn(x,n,mold,scratch) - integer(psb_mpk_), intent(in) :: n - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - class(psb_z_base_vect_type), pointer :: mld - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - info = psb_success_ - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine z_vect_bld_mn - - subroutine z_vect_bld_en(x,n,mold,scratch) - integer(psb_epk_), intent(in) :: n - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(in), optional :: mold - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) - endif - if (info == psb_success_) call x%v%bld(n,scratch=scratch_) - - end subroutine z_vect_bld_en - - function z_vect_get_vect(x,n) result(res) - class(psb_z_vect_type), intent(inout) :: x - complex(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - - if (allocated(x%v)) then - res = x%v%get_vect(n) - end if - end function z_vect_get_vect - - subroutine z_vect_set_scal(x,val,first,last) - class(psb_z_vect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine z_vect_set_scal - - subroutine z_vect_set_vect(x,val,first,last) - class(psb_z_vect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val,first,last) - - end subroutine z_vect_set_vect - - subroutine z_vect_check_addr(x) - class(psb_z_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%check_addr() - - end subroutine z_vect_check_addr - function constructor(x) result(this) complex(psb_dpk_) :: x(:) type(psb_z_vect_type) :: this @@ -566,912 +942,8 @@ contains end function size_const - function z_vect_get_nrows(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function z_vect_get_nrows - - function z_vect_sizeof(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function z_vect_sizeof - - function z_vect_get_fmt(x) result(res) - implicit none - class(psb_z_vect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function z_vect_get_fmt - - 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 - - if (allocated(x%v)) & - & call x%free(info) - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_z_base_vect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(n,info) - else - info = psb_err_alloc_dealloc_ - end if - call x%set_bld() - end subroutine z_vect_all - - subroutine z_vect_reinit(x, info, clear) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - - if (allocated(x%v)) call x%v%reinit(info,clear) - call x%set_upd() - - end subroutine z_vect_reinit - - subroutine z_vect_reall(n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(n,info) - if (info == 0) & - & call x%asb(n,info) - - end subroutine z_vect_reall - - subroutine z_vect_zero(x) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine z_vect_zero - - subroutine z_vect_asb(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - if (allocated(x%v)) then - call x%v%asb(n,info,scratch=scratch) - call x%set_asb() - end if - end subroutine z_vect_asb - - subroutine z_vect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: alpha, beta, y(:) - class(psb_z_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine z_vect_gthab - - subroutine z_vect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: y(:) - class(psb_z_vect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine z_vect_gthzv - - subroutine z_vect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: beta, x(:) - class(psb_z_vect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine z_vect_sctb - - subroutine z_vect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine z_vect_free - - subroutine z_vect_ins_a(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine z_vect_ins_a - - subroutine z_vect_ins_v(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, maxr - 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, 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,maxr,info) - - end subroutine z_vect_ins_v - - - subroutine z_vect_cnv(x,mold) - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(in), optional :: mold - class(psb_z_base_vect_type), allocatable :: tmp - - integer(psb_ipk_) :: info - - info = psb_success_ - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info,mold=psb_z_get_base_vect_default()) - end if - if (allocated(x%v)) then - if (allocated(x%v%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%base_cpy(tmp) - call x%v%free(info) - endif - end if - call move_alloc(tmp,x%v) - - end subroutine z_vect_cnv - - - subroutine z_vect_sync(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine z_vect_sync - - subroutine z_vect_set_sync(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_sync() - - end subroutine z_vect_set_sync - - subroutine z_vect_set_host(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_host() - - end subroutine z_vect_set_host - - subroutine z_vect_set_dev(x) - implicit none - class(psb_z_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%set_dev() - - end subroutine z_vect_set_dev - - function z_vect_is_sync(x) result(res) - implicit none - logical :: res - class(psb_z_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_sync() - - end function z_vect_is_sync - - function z_vect_is_host(x) result(res) - implicit none - logical :: res - class(psb_z_vect_type), intent(inout) :: x - - res = .true. - if (allocated(x%v)) & - & res = x%v%is_host() - - end function z_vect_is_host - - function z_vect_is_dev(x) result(res) - implicit none - logical :: res - class(psb_z_vect_type), intent(inout) :: x - - res = .false. - if (allocated(x%v)) & - & res = x%v%is_dev() - - end function z_vect_is_dev - - - function z_vect_get_entry(x,index) result(res) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_dpk_) :: res - res = zzero - if (allocated(x%v)) res = x%v%get_entry(index) - end function z_vect_get_entry - - subroutine z_vect_set_entry(x,index,val) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_dpk_) :: val - - if (allocated(x%v)) call x%v%set_entry(index,val) - end subroutine z_vect_set_entry - - function z_vect_dot_v(n,x,y) result(res) - implicit none - class(psb_z_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - complex(psb_dpk_) :: res - - res = zzero - if (allocated(x%v).and.allocated(y%v)) & - & res = x%v%dot(n,y%v) - - end function z_vect_dot_v - - function z_vect_dot_a(n,x,y) result(res) - implicit none - class(psb_z_vect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - complex(psb_dpk_) :: res - - res = zzero - if (allocated(x%v)) & - & res = x%v%dot_a(n,y) - - end function z_vect_dot_a - - subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call y%v%axpby(m,alpha,x%v,beta,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine z_vect_axpby_v - - subroutine z_vect_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - class(psb_z_vect_type), intent(inout) :: z - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v).and.allocated(y%v)) then - call z%v%axpby(m,alpha,x%v,beta,y%v,info) - else - info = psb_err_invalid_vect_state_ - end if - - end subroutine z_vect_axpby_v2 - - subroutine z_vect_axpby_a(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - complex(psb_dpk_), intent(in) :: x(:) - class(psb_z_vect_type), intent(inout) :: y - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(y%v)) & - & call y%v%axpby(m,alpha,x,beta,info) - - end subroutine z_vect_axpby_a - - subroutine z_vect_axpby_a2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - complex(psb_dpk_), intent(in) :: x(:) - complex(psb_dpk_), intent(in) :: y(:) - class(psb_z_vect_type), intent(inout) :: z - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - & call z%v%axpby(m,alpha,x,beta,y,info) - - end subroutine z_vect_axpby_a2 - - subroutine z_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - class(psb_z_vect_type), intent(inout) :: z - complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (allocated(z%v)) & - call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) - - end subroutine z_vect_upd_xyz - - subroutine z_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - class(psb_z_vect_type), intent(inout) :: z - class(psb_z_vect_type), intent(inout) :: w - complex(psb_dpk_), intent (in) :: a, b, c, d, e, f - integer(psb_ipk_), intent(out) :: info - - if (allocated(w%v)) & - call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) - - end subroutine z_vect_xyzw - - - subroutine z_vect_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%mlt(x%v,info) - - end subroutine z_vect_mlt_v - - subroutine z_vect_mlt_a(x, y, info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: x(:) - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - - info = 0 - if (allocated(y%v)) & - & call y%v%mlt(x,info) - - end subroutine z_vect_mlt_a - - - subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: alpha,beta - complex(psb_dpk_), intent(in) :: y(:) - complex(psb_dpk_), intent(in) :: x(:) - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%mlt(alpha,x,y,beta,info) - - end subroutine z_vect_mlt_a_2 - - subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: alpha,beta - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.& - & allocated(z%v)) & - & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) - - end subroutine z_vect_mlt_v_2 - - subroutine z_vect_mlt_av(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: alpha,beta - complex(psb_dpk_), intent(in) :: x(:) - class(psb_z_vect_type), intent(inout) :: y - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v).and.allocated(y%v)) & - & call z%v%mlt(alpha,x,y%v,beta,info) - - end subroutine z_vect_mlt_av - - subroutine z_vect_mlt_va(alpha,x,y,beta,z,info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: alpha,beta - complex(psb_dpk_), intent(in) :: y(:) - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - - if (allocated(z%v).and.allocated(x%v)) & - & call z%v%mlt(alpha,x%v,y,beta,info) - - end subroutine z_vect_mlt_va - - subroutine z_vect_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info) - - end subroutine z_vect_div_v - - subroutine z_vect_div_v2( x, y, z, info) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info) - - end subroutine z_vect_div_v2 - - subroutine z_vect_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call x%v%div(y%v,info,flag) - - end subroutine z_vect_div_v_check - - subroutine z_vect_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & - & call z%v%div(x%v,y%v,info,flag) - - end subroutine z_vect_div_v2_check - - subroutine z_vect_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: x(:) - complex(psb_dpk_), intent(in) :: y(:) - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info) - - end subroutine z_vect_div_a2 - - subroutine z_vect_div_a2_check(x, y, z, info,flag) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: x(:) - complex(psb_dpk_), intent(in) :: y(:) - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(z%v)) & - & call z%v%div(x,y,info,flag) - - end subroutine z_vect_div_a2_check - - subroutine z_vect_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info) - - end subroutine z_vect_inv_v - - subroutine z_vect_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(x%v).and.allocated(y%v)) & - & call y%v%inv(x%v,info,flag) - - end subroutine z_vect_inv_v_check - - subroutine z_vect_inv_a2(x, y, info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info) - - end subroutine z_vect_inv_a2 - - subroutine z_vect_inv_a2_check(x, y, info,flag) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (allocated(y%v)) & - & call y%v%inv(x,info,flag) - - end subroutine z_vect_inv_a2_check - - subroutine z_vect_acmp_a2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: c - complex(psb_dpk_), intent(inout) :: x(:) - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%acmp(x,c,info) - - end subroutine z_vect_acmp_a2 - - subroutine z_vect_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: c - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%acmp(x%v,c,info) - - end subroutine z_vect_acmp_v2 - - subroutine z_vect_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - complex(psb_dpk_), intent (in) :: alpha - - if (allocated(x%v)) call x%v%scal(alpha) - - end subroutine z_vect_scal - - subroutine z_vect_absval1(x) - class(psb_z_vect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%absval() - - end subroutine z_vect_absval1 - - subroutine z_vect_absval2(x,y) - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: y - - if (allocated(x%v)) then - if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) - call x%v%absval(y%v) - end if - end subroutine z_vect_absval2 - - function z_vect_nrm2(n,x) result(res) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - if (allocated(x%v)) then - res = x%v%nrm2(n) - else - res = dzero - end if - - end function z_vect_nrm2 - - function z_vect_nrm2_weight(n,x,w,aux) result(res) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: w - class(psb_z_vect_type), intent(inout), optional :: aux - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_) :: info - - ! Temp vectors - type(psb_z_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,zone,w%v%v,zzero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -done - return - end if - - if (allocated(x%v)) then - if (.not.present(aux)) then - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = dzero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function z_vect_nrm2_weight - - function z_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) - use psi_serial_mod - implicit none - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: w - class(psb_z_vect_type), intent(inout) :: id - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_), intent(out) :: info - class(psb_z_vect_type), intent(inout), optional :: aux - - ! Temp vectors - type(psb_z_vect_type) :: wtemp - - info = 0 - if( allocated(w%v) ) then - if (.not.present(aux)) then - allocate(wtemp%v, mold=w%v) - call wtemp%v%bld(w%get_vect()) - else - call psb_geaxpby(n,zone,w%v%v,zzero,aux%v%v,info) - end if - else - info = -1 - end if - if (info /= 0 ) then - res = -done - return - end if - - - if (allocated(x%v).and.allocated(id%v)) then - if (.not.present(aux)) then - where( abs(id%v%v) <= dzero) wtemp%v%v = dzero - call wtemp%set_host() - call wtemp%v%mlt(x%v,info) - res = wtemp%v%nrm2(n) - else - where( abs(id%v%v) <= dzero) aux%v%v = dzero - call aux%set_host() - call aux%v%mlt(x%v,info) - res = aux%v%nrm2(n) - end if - else - res = dzero - end if - - if (.not.present(aux)) then - call wtemp%free(info) - end if - - end function z_vect_nrm2_weight_mask - - function z_vect_amax(n,x) result(res) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - if (allocated(x%v)) then - res = x%v%amax(n) - else - res = dzero - end if - - end function z_vect_amax - - - function z_vect_asum(n,x) result(res) - implicit none - class(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - - if (allocated(x%v)) then - res = x%v%asum(n) - else - res = dzero - end if - - end function z_vect_asum - - - - subroutine z_vect_addconst_a2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: b - complex(psb_dpk_), intent(inout) :: x(:) - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(z%v)) & - & call z%addconst(x,b,info) - - end subroutine z_vect_addconst_a2 - - subroutine z_vect_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: b - class(psb_z_vect_type), intent(inout) :: x - class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v).and.allocated(z%v)) & - & call z%v%addconst(x%v,b,info) - - end subroutine z_vect_addconst_v2 - end module psb_z_vect_mod - module psb_z_multivect_mod use psb_z_base_multivect_mod @@ -1552,410 +1024,239 @@ module psb_z_multivect_mod class(psb_z_base_multivect_type), allocatable, target,& & save, private :: psb_z_base_multivect_default - interface psb_set_multivect_default - module procedure psb_z_set_multivect_default - end interface psb_set_multivect_default - - interface psb_get_multivect_default - module procedure psb_z_get_multivect_default - end interface psb_get_multivect_default - - -contains - - function z_mvect_get_dupl(x) result(res) - implicit none - class(psb_z_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function z_mvect_get_dupl - - subroutine z_mvect_set_dupl(x,val) - implicit none - class(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%dupl = val - else - x%dupl = psb_dupl_def_ - end if - end subroutine z_mvect_set_dupl - - - function z_mvect_is_remote_build(x) result(res) - implicit none - class(psb_z_multivect_type), intent(in) :: x - logical :: res - res = (x%remote_build == psb_matbld_remote_) - end function z_mvect_is_remote_build - - subroutine z_mvect_set_remote_build(x,val) - implicit none - class(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in), optional :: val - - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine z_mvect_set_remote_build - - - subroutine psb_z_set_multivect_default(v) - implicit none - class(psb_z_base_multivect_type), intent(in) :: v - - if (allocated(psb_z_base_multivect_default)) then - deallocate(psb_z_base_multivect_default) - end if - allocate(psb_z_base_multivect_default, mold=v) - - end subroutine psb_z_set_multivect_default - - function psb_z_get_multivect_default(v) result(res) - implicit none - class(psb_z_multivect_type), intent(in) :: v - class(psb_z_base_multivect_type), pointer :: res - - res => psb_z_get_base_multivect_default() - - end function psb_z_get_multivect_default - - - function psb_z_get_base_multivect_default() result(res) - implicit none - class(psb_z_base_multivect_type), pointer :: res - - if (.not.allocated(psb_z_base_multivect_default)) then - allocate(psb_z_base_multivect_type :: psb_z_base_multivect_default) - end if - - res => psb_z_base_multivect_default - - end function psb_z_get_base_multivect_default - - - subroutine z_mvect_clone(x,y,info) - implicit none - class(psb_z_multivect_type), intent(inout) :: x - class(psb_z_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = psb_success_ - call y%free(info) - if ((info==0).and.allocated(x%v)) then - call y%bld_x(x%get_vect(),mold=x%v) - end if - end subroutine z_mvect_clone - - subroutine z_mvect_bld_x(x,invect,mold) - complex(psb_dpk_), intent(in) :: invect(:,:) - class(psb_z_multivect_type), intent(out) :: x - class(psb_z_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - class(psb_z_base_multivect_type), pointer :: mld - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) - endif - - if (info == psb_success_) call x%v%bld(invect) - - end subroutine z_mvect_bld_x - - - subroutine z_mvect_bld_n(x,m,n,mold,scratch) - integer(psb_ipk_), intent(in) :: m,n - class(psb_z_multivect_type), intent(out) :: x - class(psb_z_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - info = psb_success_ - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) - endif - if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) - - end subroutine z_mvect_bld_n - - function z_mvect_get_vect(x) result(res) - class(psb_z_multivect_type), intent(inout) :: x - complex(psb_dpk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - res = x%v%get_vect() - end if - end function z_mvect_get_vect - - subroutine z_mvect_set_scal(x,val) - class(psb_z_multivect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine z_mvect_set_scal - - subroutine z_mvect_set_vect(x,val) - class(psb_z_multivect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val(:,:) - - integer(psb_ipk_) :: info - if (allocated(x%v)) call x%v%set(val) - - end subroutine z_mvect_set_vect - - - function constructor(x) result(this) - complex(psb_dpk_) :: x(:,:) - type(psb_z_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_x(x) - call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) - - end function constructor - - - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_z_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%bld_n(m,n) - call this%asb(m,n,info) - - end function size_const - - function z_mvect_get_nrows(x) result(res) - implicit none - class(psb_z_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_nrows() - end function z_mvect_get_nrows - - function z_mvect_get_ncols(x) result(res) - implicit none - class(psb_z_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%get_ncols() - end function z_mvect_get_ncols - - function z_mvect_sizeof(x) result(res) - implicit none - class(psb_z_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - res = 0 - if (allocated(x%v)) res = x%v%sizeof() - end function z_mvect_sizeof - - function z_mvect_get_fmt(x) result(res) - implicit none - class(psb_z_multivect_type), intent(in) :: x - character(len=5) :: res - res = 'NULL' - if (allocated(x%v)) res = x%v%get_fmt() - end function z_mvect_get_fmt - - subroutine z_mvect_all(m,n, x, info, mold) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_z_multivect_type), intent(out) :: x - class(psb_z_base_multivect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info - - if (present(mold)) then - allocate(x%v,stat=info,mold=mold) - else - allocate(psb_z_base_multivect_type :: x%v,stat=info) - endif - if (info == 0) then - call x%v%all(m,n,info) - else - info = psb_err_alloc_dealloc_ - end if - - end subroutine z_mvect_all - - subroutine z_mvect_reall(m,n, x, info) - - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (.not.allocated(x%v)) & - & call x%all(m,n,info) - if (info == 0) & - & call x%asb(m,n,info) - - end subroutine z_mvect_reall - - subroutine z_mvect_zero(x) - use psi_serial_mod - implicit none - class(psb_z_multivect_type), intent(inout) :: x - - if (allocated(x%v)) call x%v%zero() - - end subroutine z_mvect_zero - - subroutine z_mvect_asb(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%v)) & - & call x%v%asb(m,n,info) - - end subroutine z_mvect_asb - - subroutine z_mvect_sync(x) - implicit none - class(psb_z_multivect_type), intent(inout) :: x - - if (allocated(x%v)) & - & call x%v%sync() - - end subroutine z_mvect_sync - - subroutine z_mvect_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: alpha, beta, y(:) - class(psb_z_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,alpha,beta,y) - - end subroutine z_mvect_gthab - - subroutine z_mvect_gthzv(n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: y(:) - class(psb_z_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(n,idx,y) - - end subroutine z_mvect_gthzv - - subroutine z_mvect_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_dpk_) :: y(:) - class(psb_z_multivect_type) :: x - - if (allocated(x%v)) & - & call x%v%gth(i,n,idx,y) - - end subroutine z_mvect_gthzv_x - - subroutine z_mvect_sctb(n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: beta, x(:) - class(psb_z_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(n,idx,x,beta) - - end subroutine z_mvect_sctb - - subroutine z_mvect_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_dpk_) :: beta, x(:) - class(psb_z_multivect_type) :: y - - if (allocated(y%v)) & - & call y%v%sct(i,n,idx,x,beta) - - end subroutine z_mvect_sctb_x - - subroutine z_mvect_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%v%free(info) - if (info == 0) deallocate(x%v,stat=info) - end if - - end subroutine z_mvect_free - - subroutine z_mvect_ins(n,irl,val,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n,maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - 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,maxr,info) - - end subroutine z_mvect_ins - - - subroutine z_mvect_cnv(x,mold) - class(psb_z_multivect_type), intent(inout) :: x - class(psb_z_base_multivect_type), intent(in), optional :: mold - class(psb_z_base_multivect_type), allocatable :: tmp - integer(psb_ipk_) :: info - - if (present(mold)) then - allocate(tmp,stat=info,mold=mold) - else - allocate(tmp,stat=info, mold=psb_z_get_base_multivect_default()) - endif - if (allocated(x%v)) then - call x%v%sync() - if (info == psb_success_) call tmp%bld(x%v%v) - call x%v%free(info) - end if - call move_alloc(tmp,x%v) - end subroutine z_mvect_cnv - - -!!$ function z_mvect_dot_v(n,x,y) result(res) + interface + module function z_mvect_get_dupl(x) result(res) + class(psb_z_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_mvect_get_dupl + end interface + + interface + module subroutine z_mvect_set_dupl(x,val) + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine z_mvect_set_dupl + end interface + + interface + module function z_mvect_is_remote_build(x) result(res) + class(psb_z_multivect_type), intent(in) :: x + logical :: res + end function z_mvect_is_remote_build + end interface + + interface + module subroutine z_mvect_set_remote_build(x,val) + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + end subroutine z_mvect_set_remote_build + end interface + + interface + module subroutine psb_z_set_multivect_default(v) + class(psb_z_base_multivect_type), intent(in) :: v + end subroutine psb_z_set_multivect_default + end interface + + interface + module function psb_z_get_multivect_default(v) result(res) + class(psb_z_multivect_type), intent(in) :: v + class(psb_z_base_multivect_type), pointer :: res + end function psb_z_get_multivect_default + end interface + + interface + module function psb_z_get_base_multivect_default() result(res) + class(psb_z_base_multivect_type), pointer :: res + end function psb_z_get_base_multivect_default + end interface + + interface + module subroutine z_mvect_clone(x,y,info) + class(psb_z_multivect_type), intent(inout) :: x + class(psb_z_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_mvect_clone + end interface + + interface + module subroutine z_mvect_bld_x(x,invect,mold) + complex(psb_dpk_), intent(in) :: invect(:,:) + class(psb_z_multivect_type), intent(out) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + end subroutine z_mvect_bld_x + end interface + + + interface + module subroutine z_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(out) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine z_mvect_bld_n + end interface + + interface + module function z_mvect_get_vect(x) result(res) + class(psb_z_multivect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:,:) + end function z_mvect_get_vect + end interface + + interface + module subroutine z_mvect_set_scal(x,val) + class(psb_z_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + end subroutine z_mvect_set_scal + end interface + + interface + module subroutine z_mvect_set_vect(x,val) + class(psb_z_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:,:) + end subroutine z_mvect_set_vect + end interface + + interface + module function z_mvect_get_nrows(x) result(res) + class(psb_z_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_mvect_get_nrows + end interface + + interface + module function z_mvect_get_ncols(x) result(res) + class(psb_z_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_mvect_get_ncols + end interface + + interface + module function z_mvect_sizeof(x) result(res) + class(psb_z_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function z_mvect_sizeof + end interface + + interface + module function z_mvect_get_fmt(x) result(res) + class(psb_z_multivect_type), intent(in) :: x + character(len=5) :: res + end function z_mvect_get_fmt + end interface + + interface + module subroutine z_mvect_all(m,n, x, info, mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(out) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + end subroutine z_mvect_all + end interface + + interface + module subroutine z_mvect_reall(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_mvect_reall + end interface + + interface + module subroutine z_mvect_zero(x) + class(psb_z_multivect_type), intent(inout) :: x + end subroutine z_mvect_zero + end interface + + interface + module subroutine z_mvect_asb(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_mvect_asb + end interface + + interface + module subroutine z_mvect_sync(x) + class(psb_z_multivect_type), intent(inout) :: x + end subroutine z_mvect_sync + end interface + + interface + module subroutine z_mvect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_multivect_type) :: x + end subroutine z_mvect_gthab + end interface + + interface + module subroutine z_mvect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_multivect_type) :: x + end subroutine z_mvect_gthzv + end interface + + interface + module subroutine z_mvect_gthzv_x(i,n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: y(:) + class(psb_z_multivect_type) :: x + end subroutine z_mvect_gthzv_x + end interface + + interface + module subroutine z_mvect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_multivect_type) :: y + end subroutine z_mvect_sctb + end interface + + interface + module subroutine z_mvect_sctb_x(i,n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta, x(:) + class(psb_z_multivect_type) :: y + end subroutine z_mvect_sctb_x + end interface + + interface + module subroutine z_mvect_free(x, info) + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_mvect_free + end interface + + interface + module subroutine z_mvect_ins(n,irl,val,x,maxr,info) + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine z_mvect_ins + end interface + + interface + module subroutine z_mvect_cnv(x,mold) + class(psb_z_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + end subroutine z_mvect_cnv + end interface + + +!!$ module function z_mvect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n @@ -1967,7 +1268,7 @@ contains !!$ !!$ end function z_mvect_dot_v !!$ -!!$ function z_mvect_dot_a(n,x,y) result(res) +!!$ module function z_mvect_dot_a(n,x,y) result(res) !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ complex(psb_dpk_), intent(in) :: y(:) @@ -1980,7 +1281,7 @@ contains !!$ !!$ end function z_mvect_dot_a !!$ -!!$ subroutine z_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ module subroutine z_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -1997,7 +1298,7 @@ contains !!$ !!$ end subroutine z_mvect_axpby_v !!$ -!!$ subroutine z_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ module subroutine z_mvect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m @@ -2012,7 +1313,7 @@ contains !!$ end subroutine z_mvect_axpby_a !!$ !!$ -!!$ subroutine z_mvect_mlt_v(x, y, info) +!!$ module subroutine z_mvect_mlt_v(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x @@ -2026,7 +1327,7 @@ contains !!$ !!$ end subroutine z_mvect_mlt_v !!$ -!!$ subroutine z_mvect_mlt_a(x, y, info) +!!$ module subroutine z_mvect_mlt_a(x, y, info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_dpk_), intent(in) :: x(:) @@ -2042,7 +1343,7 @@ contains !!$ end subroutine z_mvect_mlt_a !!$ !!$ -!!$ subroutine z_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ module subroutine z_mvect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta @@ -2058,7 +1359,7 @@ contains !!$ !!$ end subroutine z_mvect_mlt_a_2 !!$ -!!$ subroutine z_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ module subroutine z_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta @@ -2076,8 +1377,8 @@ contains !!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) !!$ !!$ end subroutine z_mvect_mlt_v_2 -!!$ -!!$ subroutine z_mvect_mlt_av(alpha,x,y,beta,z,info) + +!!$ module subroutine z_mvect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta @@ -2093,7 +1394,7 @@ contains !!$ !!$ end subroutine z_mvect_mlt_av !!$ -!!$ subroutine z_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ module subroutine z_mvect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod !!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta @@ -2110,7 +1411,7 @@ contains !!$ !!$ end subroutine z_mvect_mlt_va !!$ -!!$ subroutine z_mvect_scal(alpha, x) +!!$ module subroutine z_mvect_scal(alpha, x) !!$ use psi_serial_mod !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x @@ -2121,7 +1422,7 @@ contains !!$ end subroutine z_mvect_scal !!$ !!$ -!!$ function z_mvect_nrm2(n,x) result(res) +!!$ module function z_mvect_nrm2(n,x) result(res) !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2135,7 +1436,7 @@ contains !!$ !!$ end function z_mvect_nrm2 !!$ -!!$ function z_mvect_amax(n,x) result(res) +!!$ module function z_mvect_amax(n,x) result(res) !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2149,7 +1450,7 @@ contains !!$ !!$ end function z_mvect_amax !!$ -!!$ function z_mvect_asum(n,x) result(res) +!!$ module function z_mvect_asum(n,x) result(res) !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n @@ -2163,5 +1464,26 @@ contains !!$ !!$ end function z_mvect_asum -end module psb_z_multivect_mod +contains + + function constructor(x) result(this) + complex(psb_dpk_) :: x(:,:) + type(psb_z_multivect_type) :: this + integer(psb_ipk_) :: info + call this%bld_x(x) + call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + + end function constructor + + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_z_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld_n(m,n) + call this%asb(m,n,info) + + end function size_const + +end module psb_z_multivect_mod diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index 971dfb6e..f1716976 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -7,7 +7,10 @@ BOBJS=psb_base_mat_impl.o \ psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o \ psb_i_base_vect_impl.o psb_l_base_vect_impl.o \ psb_s_base_vect_impl.o psb_d_base_vect_impl.o \ - psb_c_base_vect_impl.o psb_z_base_vect_impl.o + psb_c_base_vect_impl.o psb_z_base_vect_impl.o \ + psb_i_vect_impl.o psb_l_vect_impl.o \ + psb_s_vect_impl.o psb_d_vect_impl.o \ + psb_c_vect_impl.o psb_z_vect_impl.o #\ psb_s_lbase_mat_impl.o psb_d_lbase_mat_impl.o psb_c_lbase_mat_impl.o psb_z_lbase_mat_impl.o diff --git a/base/serial/impl/psb_c_vect_impl.F90 b/base/serial/impl/psb_c_vect_impl.F90 new file mode 100644 index 00000000..8a59b85f --- /dev/null +++ b/base/serial/impl/psb_c_vect_impl.F90 @@ -0,0 +1,1843 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_c_vect_mod +! +! This module contains the definition of the psb_c_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +submodule (psb_c_vect_mod) psb_c_vect_impl + use psi_serial_mod + use psb_realloc_mod +contains + + module function c_vect_get_dupl(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_dupl() + else + res = psb_dupl_null_ + end if + end function c_vect_get_dupl + + module subroutine c_vect_set_dupl(x,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if + end if + end subroutine c_vect_set_dupl + + module function c_vect_get_ncfs(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function c_vect_get_ncfs + + module subroutine c_vect_set_ncfs(x,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine c_vect_set_ncfs + + module function c_vect_get_state(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function c_vect_get_state + + module function c_vect_is_null(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function c_vect_is_null + + module function c_vect_is_bld(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function c_vect_is_bld + + module function c_vect_is_upd(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function c_vect_is_upd + + module function c_vect_is_asb(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function c_vect_is_asb + + module subroutine c_vect_set_state(n,x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine c_vect_set_state + + + module subroutine c_vect_set_null(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine c_vect_set_null + + module subroutine c_vect_set_bld(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine c_vect_set_bld + + module subroutine c_vect_set_upd(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine c_vect_set_upd + + module subroutine c_vect_set_asb(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine c_vect_set_asb + + module 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 + + module 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 + + module function c_vect_is_remote_build(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function c_vect_is_remote_build + + module subroutine c_vect_set_remote_build(x,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine c_vect_set_remote_build + + module subroutine psb_c_set_vect_default(v) + implicit none + class(psb_c_base_vect_type), intent(in) :: v + + if (allocated(psb_c_base_vect_default)) then + deallocate(psb_c_base_vect_default) + end if + allocate(psb_c_base_vect_default, mold=v) + + end subroutine psb_c_set_vect_default + + module function psb_c_get_vect_default(v) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: v + class(psb_c_base_vect_type), pointer :: res + + res => psb_c_get_base_vect_default() + + end function psb_c_get_vect_default + + module subroutine psb_c_clear_vect_default() + implicit none + + if (allocated(psb_c_base_vect_default)) then + deallocate(psb_c_base_vect_default) + end if + + end subroutine psb_c_clear_vect_default + + module function psb_c_get_base_vect_default() result(res) + implicit none + class(psb_c_base_vect_type), pointer :: res + + if (.not.allocated(psb_c_base_vect_default)) then + allocate(psb_c_base_vect_type :: psb_c_base_vect_default) + end if + + res => psb_c_base_vect_default + + end function psb_c_get_base_vect_default + + module subroutine c_vect_clone(x,y,info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + ! + ! Using sourced allocation here creates + ! problems with handling of memory allocated + ! elsewhere (e.g. accelerators), hence delegation + ! to %bld method + ! + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine c_vect_clone + + module subroutine c_vect_bld_x(x,invect,mold,scratch) + complex(psb_spk_), intent(in) :: invect(:) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) + + end subroutine c_vect_bld_x + + + module subroutine c_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + class(psb_c_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine c_vect_bld_mn + + module subroutine c_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine c_vect_bld_en + + module function c_vect_get_vect(x,n) result(res) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function c_vect_get_vect + + module subroutine c_vect_set_scal(x,val,first,last) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine c_vect_set_scal + + module subroutine c_vect_set_vect(x,val,first,last) + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine c_vect_set_vect + + module subroutine c_vect_check_addr(x) + class(psb_c_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%check_addr() + + end subroutine c_vect_check_addr + + module function c_vect_get_nrows(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function c_vect_get_nrows + + module function c_vect_sizeof(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function c_vect_sizeof + + module function c_vect_get_fmt(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function c_vect_get_fmt + + module 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 + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_c_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + call x%set_bld() + end subroutine c_vect_all + + module subroutine c_vect_reinit(x, info, clear) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + if (allocated(x%v)) call x%v%reinit(info,clear) + call x%set_upd() + + end subroutine c_vect_reinit + + module subroutine c_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine c_vect_reall + + module subroutine c_vect_zero(x) + + implicit none + class(psb_c_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine c_vect_zero + + module subroutine c_vect_asb(n, x, info, scratch) + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + if (allocated(x%v)) then + call x%v%asb(n,info,scratch=scratch) + call x%set_asb() + end if + end subroutine c_vect_asb + + module subroutine c_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine c_vect_gthab + + module subroutine c_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine c_vect_gthzv + + module subroutine c_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine c_vect_sctb + + module subroutine c_vect_free(x, info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine c_vect_free + + module subroutine c_vect_ins_a(n,irl,val,x,maxr,info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine c_vect_ins_a + + module subroutine c_vect_ins_v(n,irl,val,x,maxr,info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + 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, 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,maxr,info) + + end subroutine c_vect_ins_v + + + module subroutine c_vect_cnv(x,mold) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + class(psb_c_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_c_get_base_vect_default()) + end if + if (allocated(x%v)) then + if (allocated(x%v%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) + call x%v%free(info) + endif + end if + call move_alloc(tmp,x%v) + + end subroutine c_vect_cnv + + + module subroutine c_vect_sync(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine c_vect_sync + + module subroutine c_vect_set_sync(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine c_vect_set_sync + + module subroutine c_vect_set_host(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine c_vect_set_host + + module subroutine c_vect_set_dev(x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine c_vect_set_dev + + module function c_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_c_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function c_vect_is_sync + + module function c_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_c_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function c_vect_is_host + + module function c_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_c_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function c_vect_is_dev + + + module function c_vect_get_entry(x,index) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: res + res = czero + if (allocated(x%v)) res = x%v%get_entry(index) + end function c_vect_get_entry + + module subroutine c_vect_set_entry(x,index,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine c_vect_set_entry + + module function c_vect_dot_v(n,x,y) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + + res = czero + if (allocated(x%v).and.allocated(y%v)) & + & res = x%v%dot(n,y%v) + + end function c_vect_dot_v + + module function c_vect_dot_a(n,x,y) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + + res = czero + if (allocated(x%v)) & + & res = x%v%dot_a(n,y) + + end function c_vect_dot_a + + module subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call y%v%axpby(m,alpha,x%v,beta,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine c_vect_axpby_v + + module subroutine c_vect_axpby_v2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine c_vect_axpby_v2 + + module subroutine c_vect_axpby_a(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(y%v)) & + & call y%v%axpby(m,alpha,x,beta,info) + + end subroutine c_vect_axpby_a + + module subroutine c_vect_axpby_a2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine c_vect_axpby_a2 + + module subroutine c_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) + + end subroutine c_vect_upd_xyz + + module subroutine c_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + class(psb_c_vect_type), intent(inout) :: w + complex(psb_spk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + + if (allocated(w%v)) & + call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) + + end subroutine c_vect_xyzw + + + module subroutine c_vect_mlt_v(x, y, info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%mlt(x%v,info) + + end subroutine c_vect_mlt_v + + module subroutine c_vect_mlt_a(x, y, info) + implicit none + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + + info = 0 + if (allocated(y%v)) & + & call y%v%mlt(x,info) + + end subroutine c_vect_mlt_a + + + module subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info) + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: y(:) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%mlt(alpha,x,y,beta,info) + + end subroutine c_vect_mlt_a_2 + + module subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.& + & allocated(z%v)) & + & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) + + end subroutine c_vect_mlt_v_2 + + module subroutine c_vect_mlt_av(alpha,x,y,beta,z,info) + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v).and.allocated(y%v)) & + & call z%v%mlt(alpha,x,y%v,beta,info) + + end subroutine c_vect_mlt_av + + module subroutine c_vect_mlt_va(alpha,x,y,beta,z,info) + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + + if (allocated(z%v).and.allocated(x%v)) & + & call z%v%mlt(alpha,x%v,y,beta,info) + + end subroutine c_vect_mlt_va + + module subroutine c_vect_div_v(x, y, info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine c_vect_div_v + + module subroutine c_vect_div_v2( x, y, z, info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine c_vect_div_v2 + + module subroutine c_vect_div_v_check(x, y, info, flag) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine c_vect_div_v_check + + module subroutine c_vect_div_v2_check(x, y, z, info, flag) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine c_vect_div_v2_check + + module subroutine c_vect_div_a2(x, y, z, info) + implicit none + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine c_vect_div_a2 + + module subroutine c_vect_div_a2_check(x, y, z, info,flag) + implicit none + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine c_vect_div_a2_check + + module subroutine c_vect_inv_v(x, y, info) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine c_vect_inv_v + + module subroutine c_vect_inv_v_check(x, y, info, flag) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine c_vect_inv_v_check + + module subroutine c_vect_inv_a2(x, y, info) + implicit none + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine c_vect_inv_a2 + + module subroutine c_vect_inv_a2_check(x, y, info,flag) + + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine c_vect_inv_a2_check + + module subroutine c_vect_acmp_a2(x,c,z,info) + implicit none + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine c_vect_acmp_a2 + + module subroutine c_vect_acmp_v2(x,c,z,info) + implicit none + real(psb_spk_), intent(in) :: c + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine c_vect_acmp_v2 + + module subroutine c_vect_scal(alpha, x) + implicit none + class(psb_c_vect_type), intent(inout) :: x + complex(psb_spk_), intent (in) :: alpha + + if (allocated(x%v)) call x%v%scal(alpha) + + end subroutine c_vect_scal + + module subroutine c_vect_absval1(x) + class(psb_c_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%absval() + + end subroutine c_vect_absval1 + + module subroutine c_vect_absval2(x,y) + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + + if (allocated(x%v)) then + if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) + call x%v%absval(y%v) + end if + end subroutine c_vect_absval2 + + module function c_vect_nrm2(n,x) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then + res = x%v%nrm2(n) + else + res = szero + end if + + end function c_vect_nrm2 + + module function c_vect_nrm2_weight(n,x,w,aux) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: w + class(psb_c_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: info + + ! Temp vectors + type(psb_c_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,cone,w%v%v,czero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -sone + return + end if + + if (allocated(x%v)) then + if (.not.present(aux)) then + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = szero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function c_vect_nrm2_weight + + module function c_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: w + class(psb_c_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_c_vect_type), intent(inout), optional :: aux + + ! Temp vectors + type(psb_c_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,cone,w%v%v,czero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -sone + return + end if + + + if (allocated(x%v).and.allocated(id%v)) then + if (.not.present(aux)) then + where( abs(id%v%v) <= szero) wtemp%v%v = szero + call wtemp%set_host() + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + where( abs(id%v%v) <= szero) aux%v%v = szero + call aux%set_host() + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = szero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function c_vect_nrm2_weight_mask + + module function c_vect_amax(n,x) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then + res = x%v%amax(n) + else + res = szero + end if + + end function c_vect_amax + + + module function c_vect_asum(n,x) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then + res = x%v%asum(n) + else + res = szero + end if + + end function c_vect_asum + + + + module subroutine c_vect_addconst_a2(x,b,z,info) + implicit none + real(psb_spk_), intent(in) :: b + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine c_vect_addconst_a2 + + module subroutine c_vect_addconst_v2(x,b,z,info) + + real(psb_spk_), intent(in) :: b + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine c_vect_addconst_v2 + +end submodule psb_c_vect_impl + + +submodule (psb_c_multivect_mod) psb_c_multivect_impl + use psi_serial_mod + use psb_realloc_mod + +contains + + module function c_mvect_get_dupl(x) result(res) + implicit none + class(psb_c_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function c_mvect_get_dupl + + module subroutine c_mvect_set_dupl(x,val) + implicit none + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%dupl = val + else + x%dupl = psb_dupl_def_ + end if + end subroutine c_mvect_set_dupl + + + module function c_mvect_is_remote_build(x) result(res) + implicit none + class(psb_c_multivect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function c_mvect_is_remote_build + + module subroutine c_mvect_set_remote_build(x,val) + implicit none + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine c_mvect_set_remote_build + + + module subroutine psb_c_set_multivect_default(v) + implicit none + class(psb_c_base_multivect_type), intent(in) :: v + + if (allocated(psb_c_base_multivect_default)) then + deallocate(psb_c_base_multivect_default) + end if + allocate(psb_c_base_multivect_default, mold=v) + + end subroutine psb_c_set_multivect_default + + module function psb_c_get_multivect_default(v) result(res) + implicit none + class(psb_c_multivect_type), intent(in) :: v + class(psb_c_base_multivect_type), pointer :: res + + res => psb_c_get_base_multivect_default() + + end function psb_c_get_multivect_default + + + module function psb_c_get_base_multivect_default() result(res) + implicit none + class(psb_c_base_multivect_type), pointer :: res + + if (.not.allocated(psb_c_base_multivect_default)) then + allocate(psb_c_base_multivect_type :: psb_c_base_multivect_default) + end if + + res => psb_c_base_multivect_default + + end function psb_c_get_base_multivect_default + + + module subroutine c_mvect_clone(x,y,info) + implicit none + class(psb_c_multivect_type), intent(inout) :: x + class(psb_c_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld_x(x%get_vect(),mold=x%v) + end if + end subroutine c_mvect_clone + + module subroutine c_mvect_bld_x(x,invect,mold) + complex(psb_spk_), intent(in) :: invect(:,:) + class(psb_c_multivect_type), intent(out) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_c_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine c_mvect_bld_x + + + module subroutine c_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(out) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) + + end subroutine c_mvect_bld_n + + module function c_mvect_get_vect(x) result(res) + class(psb_c_multivect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function c_mvect_get_vect + + module subroutine c_mvect_set_scal(x,val) + class(psb_c_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine c_mvect_set_scal + + module subroutine c_mvect_set_vect(x,val) + class(psb_c_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine c_mvect_set_vect + + module function c_mvect_get_nrows(x) result(res) + implicit none + class(psb_c_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function c_mvect_get_nrows + + module function c_mvect_get_ncols(x) result(res) + implicit none + class(psb_c_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function c_mvect_get_ncols + + module function c_mvect_sizeof(x) result(res) + implicit none + class(psb_c_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function c_mvect_sizeof + + module function c_mvect_get_fmt(x) result(res) + implicit none + class(psb_c_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function c_mvect_get_fmt + + module subroutine c_mvect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(out) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_c_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine c_mvect_all + + module subroutine c_mvect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine c_mvect_reall + + module subroutine c_mvect_zero(x) + use psi_serial_mod + implicit none + class(psb_c_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine c_mvect_zero + + module subroutine c_mvect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine c_mvect_asb + + module subroutine c_mvect_sync(x) + implicit none + class(psb_c_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine c_mvect_sync + + module subroutine c_mvect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine c_mvect_gthab + + module subroutine c_mvect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine c_mvect_gthzv + + module subroutine c_mvect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: y(:) + class(psb_c_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine c_mvect_gthzv_x + + module subroutine c_mvect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine c_mvect_sctb + + module subroutine c_mvect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta, x(:) + class(psb_c_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine c_mvect_sctb_x + + module subroutine c_mvect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine c_mvect_free + + module subroutine c_mvect_ins(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine c_mvect_ins + + + module subroutine c_mvect_cnv(x,mold) + class(psb_c_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(in), optional :: mold + class(psb_c_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_c_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine c_mvect_cnv + + +!!$ module function c_mvect_dot_v(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_c_multivect_type), intent(inout) :: x, y +!!$ integer(psb_ipk_), intent(in) :: n +!!$ complex(psb_spk_) :: res +!!$ +!!$ res = czero +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & res = x%v%dot(n,y%v) +!!$ +!!$ end function c_mvect_dot_v +!!$ +!!$ module function c_mvect_dot_a(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ complex(psb_spk_), intent(in) :: y(:) +!!$ integer(psb_ipk_), intent(in) :: n +!!$ complex(psb_spk_) :: res +!!$ +!!$ res = czero +!!$ if (allocated(x%v)) & +!!$ & res = x%v%dot(n,y) +!!$ +!!$ end function c_mvect_dot_a +!!$ +!!$ module subroutine c_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ class(psb_c_multivect_type), intent(inout) :: y +!!$ complex(psb_spk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ call y%v%axpby(m,alpha,x%v,beta,info) +!!$ else +!!$ info = psb_err_invalid_mvect_state_ +!!$ end if +!!$ +!!$ end subroutine c_mvect_axpby_v +!!$ +!!$ module subroutine c_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ complex(psb_spk_), intent(in) :: x(:) +!!$ class(psb_c_multivect_type), intent(inout) :: y +!!$ complex(psb_spk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(y%v)) & +!!$ & call y%v%axpby(m,alpha,x,beta,info) +!!$ +!!$ end subroutine c_mvect_axpby_a +!!$ +!!$ +!!$ module subroutine c_mvect_mlt_v(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ class(psb_c_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & call y%v%mlt(x%v,info) +!!$ +!!$ end subroutine c_mvect_mlt_v +!!$ +!!$ module subroutine c_mvect_mlt_a(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_spk_), intent(in) :: x(:) +!!$ class(psb_c_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ +!!$ info = 0 +!!$ if (allocated(y%v)) & +!!$ & call y%v%mlt(x,info) +!!$ +!!$ end subroutine c_mvect_mlt_a +!!$ +!!$ +!!$ module subroutine c_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_spk_), intent(in) :: alpha,beta +!!$ complex(psb_spk_), intent(in) :: y(:) +!!$ complex(psb_spk_), intent(in) :: x(:) +!!$ class(psb_c_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x,y,beta,info) +!!$ +!!$ end subroutine c_mvect_mlt_a_2 +!!$ +!!$ module subroutine c_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_spk_), intent(in) :: alpha,beta +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ class(psb_c_multivect_type), intent(inout) :: y +!!$ class(psb_c_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ character(len=1), intent(in), optional :: conjgx, conjgy +!!$ +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v).and.& +!!$ & allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) +!!$ +!!$ end subroutine c_mvect_mlt_v_2 +!!$ +!!$ module subroutine c_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_spk_), intent(in) :: alpha,beta +!!$ complex(psb_spk_), intent(in) :: x(:) +!!$ class(psb_c_multivect_type), intent(inout) :: y +!!$ class(psb_c_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v).and.allocated(y%v)) & +!!$ & call z%v%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine c_mvect_mlt_av +!!$ +!!$ module subroutine c_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_spk_), intent(in) :: alpha,beta +!!$ complex(psb_spk_), intent(in) :: y(:) +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ class(psb_c_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ if (allocated(z%v).and.allocated(x%v)) & +!!$ & call z%v%mlt(alpha,x%v,y,beta,info) +!!$ +!!$ end subroutine c_mvect_mlt_va +!!$ +!!$ module subroutine c_mvect_scal(alpha, x) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ complex(psb_spk_), intent (in) :: alpha +!!$ +!!$ if (allocated(x%v)) call x%v%scal(alpha) +!!$ +!!$ end subroutine c_mvect_scal +!!$ +!!$ +!!$ module function c_mvect_nrm2(n,x) result(res) +!!$ implicit none +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%nrm2(n) +!!$ else +!!$ res = szero +!!$ end if +!!$ +!!$ end function c_mvect_nrm2 +!!$ +!!$ module function c_mvect_amax(n,x) result(res) +!!$ implicit none +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%amax(n) +!!$ else +!!$ res = szero +!!$ end if +!!$ +!!$ end function c_mvect_amax +!!$ +!!$ module function c_mvect_asum(n,x) result(res) +!!$ implicit none +!!$ class(psb_c_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%asum(n) +!!$ else +!!$ res = szero +!!$ end if +!!$ +!!$ end function c_mvect_asum + +end submodule psb_c_multivect_impl + diff --git a/base/serial/impl/psb_d_base_vect_impl.F90 b/base/serial/impl/psb_d_base_vect_impl.F90 index 24f35b95..1b693e5b 100644 --- a/base/serial/impl/psb_d_base_vect_impl.F90 +++ b/base/serial/impl/psb_d_base_vect_impl.F90 @@ -279,6 +279,7 @@ contains info = 0 if (psb_errstatus_fatal()) return + write(0,*) 'd_base_ins_a: ',n if (try_newins) then if (x%is_bld()) then ncfs_ = x%get_ncfs() @@ -1023,6 +1024,7 @@ contains if (present(last)) last_ = min(last,last_) if (x%is_dev()) call x%sync() + write(0,*)'d_base%set_scal ',val,first_,last_ #if defined(PSB_OPENMP) !$omp parallel do private(i) do i = first_, last_ @@ -1031,8 +1033,11 @@ contains #else x%v(first_:last_) = val #endif + write(0,*) 'end of set_scal',& + & ((last_-first_+1)/2+first_),& + & x%v((last_-first_+1)/2+first_) call x%set_host() - + end subroutine d_base_set_scal @@ -1093,16 +1098,18 @@ contains !! \brief Get one entry from the vector !! ! -module function d_base_get_entry(x, index) result(res) + module function d_base_get_entry(x, index) result(res) implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res res = dzero + write(0,*) 'base%get_entry ',allocated(x%v),index if (allocated(x%v)) then if (x%is_dev()) call x%sync() res = x%v(index) + write(0,*) 'base%get_entry out',index,res end if end function d_base_get_entry diff --git a/base/serial/impl/psb_d_vect_impl.F90 b/base/serial/impl/psb_d_vect_impl.F90 new file mode 100644 index 00000000..c11aba0a --- /dev/null +++ b/base/serial/impl/psb_d_vect_impl.F90 @@ -0,0 +1,1911 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_d_vect_mod +! +! This module contains the definition of the psb_d_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +submodule (psb_d_vect_mod) psb_d_vect_impl + use psi_serial_mod + use psb_realloc_mod +contains + + module function d_vect_get_dupl(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_dupl() + else + res = psb_dupl_null_ + end if + end function d_vect_get_dupl + + module subroutine d_vect_set_dupl(x,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if + end if + end subroutine d_vect_set_dupl + + module function d_vect_get_ncfs(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function d_vect_get_ncfs + + module subroutine d_vect_set_ncfs(x,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine d_vect_set_ncfs + + module function d_vect_get_state(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function d_vect_get_state + + module function d_vect_is_null(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function d_vect_is_null + + module function d_vect_is_bld(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function d_vect_is_bld + + module function d_vect_is_upd(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function d_vect_is_upd + + module function d_vect_is_asb(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function d_vect_is_asb + + module subroutine d_vect_set_state(n,x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine d_vect_set_state + + + module subroutine d_vect_set_null(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine d_vect_set_null + + module subroutine d_vect_set_bld(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine d_vect_set_bld + + module subroutine d_vect_set_upd(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine d_vect_set_upd + + module subroutine d_vect_set_asb(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine d_vect_set_asb + + module 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 + + module 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 + + module function d_vect_is_remote_build(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function d_vect_is_remote_build + + module subroutine d_vect_set_remote_build(x,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine d_vect_set_remote_build + + module subroutine psb_d_set_vect_default(v) + implicit none + class(psb_d_base_vect_type), intent(in) :: v + + if (allocated(psb_d_base_vect_default)) then + deallocate(psb_d_base_vect_default) + end if + allocate(psb_d_base_vect_default, mold=v) + + end subroutine psb_d_set_vect_default + + module function psb_d_get_vect_default(v) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: v + class(psb_d_base_vect_type), pointer :: res + + res => psb_d_get_base_vect_default() + + end function psb_d_get_vect_default + + module subroutine psb_d_clear_vect_default() + implicit none + + if (allocated(psb_d_base_vect_default)) then + deallocate(psb_d_base_vect_default) + end if + + end subroutine psb_d_clear_vect_default + + module function psb_d_get_base_vect_default() result(res) + implicit none + class(psb_d_base_vect_type), pointer :: res + + if (.not.allocated(psb_d_base_vect_default)) then + allocate(psb_d_base_vect_type :: psb_d_base_vect_default) + end if + + res => psb_d_base_vect_default + + end function psb_d_get_base_vect_default + + module subroutine d_vect_clone(x,y,info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + ! + ! Using sourced allocation here creates + ! problems with handling of memory allocated + ! elsewhere (e.g. accelerators), hence delegation + ! to %bld method + ! + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine d_vect_clone + + module subroutine d_vect_bld_x(x,invect,mold,scratch) + real(psb_dpk_), intent(in) :: invect(:) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) + + end subroutine d_vect_bld_x + + + module subroutine d_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + class(psb_d_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine d_vect_bld_mn + + module subroutine d_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine d_vect_bld_en + + module function d_vect_get_vect(x,n) result(res) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function d_vect_get_vect + + module subroutine d_vect_set_scal(x,val,first,last) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine d_vect_set_scal + + module subroutine d_vect_set_vect(x,val,first,last) + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine d_vect_set_vect + + module subroutine d_vect_check_addr(x) + class(psb_d_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%check_addr() + + end subroutine d_vect_check_addr + + module function d_vect_get_nrows(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function d_vect_get_nrows + + module function d_vect_sizeof(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function d_vect_sizeof + + module function d_vect_get_fmt(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function d_vect_get_fmt + + module 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 + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_d_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + call x%set_bld() + end subroutine d_vect_all + + module subroutine d_vect_reinit(x, info, clear) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + if (allocated(x%v)) call x%v%reinit(info,clear) + call x%set_upd() + + end subroutine d_vect_reinit + + module subroutine d_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine d_vect_reall + + module subroutine d_vect_zero(x) + + implicit none + class(psb_d_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine d_vect_zero + + module subroutine d_vect_asb(n, x, info, scratch) + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + if (allocated(x%v)) then + call x%v%asb(n,info,scratch=scratch) + call x%set_asb() + end if + end subroutine d_vect_asb + + module subroutine d_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine d_vect_gthab + + module subroutine d_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine d_vect_gthzv + + module subroutine d_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine d_vect_sctb + + module subroutine d_vect_free(x, info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine d_vect_free + + module subroutine d_vect_ins_a(n,irl,val,x,maxr,info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine d_vect_ins_a + + module subroutine d_vect_ins_v(n,irl,val,x,maxr,info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + 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, 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,maxr,info) + + end subroutine d_vect_ins_v + + + module subroutine d_vect_cnv(x,mold) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + class(psb_d_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_d_get_base_vect_default()) + end if + if (allocated(x%v)) then + if (allocated(x%v%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) + call x%v%free(info) + endif + end if + call move_alloc(tmp,x%v) + + end subroutine d_vect_cnv + + + module subroutine d_vect_sync(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine d_vect_sync + + module subroutine d_vect_set_sync(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine d_vect_set_sync + + module subroutine d_vect_set_host(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine d_vect_set_host + + module subroutine d_vect_set_dev(x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine d_vect_set_dev + + module function d_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_d_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function d_vect_is_sync + + module function d_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_d_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function d_vect_is_host + + module function d_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_d_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function d_vect_is_dev + + + module function d_vect_get_entry(x,index) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: res + res = dzero + if (allocated(x%v)) res = x%v%get_entry(index) + end function d_vect_get_entry + + module subroutine d_vect_set_entry(x,index,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine d_vect_set_entry + + module function d_vect_dot_v(n,x,y) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + res = dzero + if (allocated(x%v).and.allocated(y%v)) & + & res = x%v%dot(n,y%v) + + end function d_vect_dot_v + + module function d_vect_dot_a(n,x,y) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + res = dzero + if (allocated(x%v)) & + & res = x%v%dot_a(n,y) + + end function d_vect_dot_a + + module subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call y%v%axpby(m,alpha,x%v,beta,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine d_vect_axpby_v + + module subroutine d_vect_axpby_v2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine d_vect_axpby_v2 + + module subroutine d_vect_axpby_a(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(y%v)) & + & call y%v%axpby(m,alpha,x,beta,info) + + end subroutine d_vect_axpby_a + + module subroutine d_vect_axpby_a2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine d_vect_axpby_a2 + + module subroutine d_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) + + end subroutine d_vect_upd_xyz + + module subroutine d_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + class(psb_d_vect_type), intent(inout) :: w + real(psb_dpk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + + if (allocated(w%v)) & + call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) + + end subroutine d_vect_xyzw + + + module subroutine d_vect_mlt_v(x, y, info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%mlt(x%v,info) + + end subroutine d_vect_mlt_v + + module subroutine d_vect_mlt_a(x, y, info) + implicit none + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + + info = 0 + if (allocated(y%v)) & + & call y%v%mlt(x,info) + + end subroutine d_vect_mlt_a + + + module subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info) + implicit none + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: y(:) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%mlt(alpha,x,y,beta,info) + + end subroutine d_vect_mlt_a_2 + + module subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + implicit none + real(psb_dpk_), intent(in) :: alpha,beta + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.& + & allocated(z%v)) & + & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) + + end subroutine d_vect_mlt_v_2 + + module subroutine d_vect_mlt_av(alpha,x,y,beta,z,info) + implicit none + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v).and.allocated(y%v)) & + & call z%v%mlt(alpha,x,y%v,beta,info) + + end subroutine d_vect_mlt_av + + module subroutine d_vect_mlt_va(alpha,x,y,beta,z,info) + implicit none + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + + if (allocated(z%v).and.allocated(x%v)) & + & call z%v%mlt(alpha,x%v,y,beta,info) + + end subroutine d_vect_mlt_va + + module subroutine d_vect_div_v(x, y, info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine d_vect_div_v + + module subroutine d_vect_div_v2( x, y, z, info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine d_vect_div_v2 + + module subroutine d_vect_div_v_check(x, y, info, flag) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine d_vect_div_v_check + + module subroutine d_vect_div_v2_check(x, y, z, info, flag) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine d_vect_div_v2_check + + module subroutine d_vect_div_a2(x, y, z, info) + implicit none + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine d_vect_div_a2 + + module subroutine d_vect_div_a2_check(x, y, z, info,flag) + implicit none + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine d_vect_div_a2_check + + module subroutine d_vect_inv_v(x, y, info) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine d_vect_inv_v + + module subroutine d_vect_inv_v_check(x, y, info, flag) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine d_vect_inv_v_check + + module subroutine d_vect_inv_a2(x, y, info) + implicit none + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine d_vect_inv_a2 + + module subroutine d_vect_inv_a2_check(x, y, info,flag) + + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine d_vect_inv_a2_check + + module subroutine d_vect_acmp_a2(x,c,z,info) + implicit none + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine d_vect_acmp_a2 + + module subroutine d_vect_acmp_v2(x,c,z,info) + implicit none + real(psb_dpk_), intent(in) :: c + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine d_vect_acmp_v2 + + module subroutine d_vect_scal(alpha, x) + implicit none + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent (in) :: alpha + + if (allocated(x%v)) call x%v%scal(alpha) + + end subroutine d_vect_scal + + module subroutine d_vect_absval1(x) + class(psb_d_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%absval() + + end subroutine d_vect_absval1 + + module subroutine d_vect_absval2(x,y) + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + + if (allocated(x%v)) then + if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) + call x%v%absval(y%v) + end if + end subroutine d_vect_absval2 + + module function d_vect_nrm2(n,x) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then + res = x%v%nrm2(n) + else + res = dzero + end if + + end function d_vect_nrm2 + + module function d_vect_nrm2_weight(n,x,w,aux) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: w + class(psb_d_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: info + + ! Temp vectors + type(psb_d_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,done,w%v%v,dzero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -done + return + end if + + if (allocated(x%v)) then + if (.not.present(aux)) then + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = dzero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function d_vect_nrm2_weight + + module function d_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: w + class(psb_d_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_d_vect_type), intent(inout), optional :: aux + + ! Temp vectors + type(psb_d_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,done,w%v%v,dzero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -done + return + end if + + + if (allocated(x%v).and.allocated(id%v)) then + if (.not.present(aux)) then + where( abs(id%v%v) <= dzero) wtemp%v%v = dzero + call wtemp%set_host() + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + where( abs(id%v%v) <= dzero) aux%v%v = dzero + call aux%set_host() + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = dzero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function d_vect_nrm2_weight_mask + + module function d_vect_amax(n,x) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then + res = x%v%amax(n) + else + res = dzero + end if + + end function d_vect_amax + + module function d_vect_min(n,x) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then + res = x%v%minreal(n) + else + res = HUGE(dzero) + end if + + end function d_vect_min + + module function d_vect_asum(n,x) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then + res = x%v%asum(n) + else + res = dzero + end if + + end function d_vect_asum + + + module subroutine d_vect_mask_a(c,x,m,t,info) + implicit none + real(psb_dpk_), intent(inout) :: c(:) + real(psb_dpk_), intent(inout) :: x(:) + logical, intent(out) :: t; + class(psb_d_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(m%v)) & + & call m%mask(c,x,t,info) + + end subroutine d_vect_mask_a + + module subroutine d_vect_mask_v(c,x,m,t,info) + implicit none + class(psb_d_vect_type), intent(inout) :: c + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: m + logical, intent(out) :: t; + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(c%v)) & + & call m%v%mask(x%v,c%v,t,info) + + end subroutine d_vect_mask_v + + module function d_vect_minquotient_v(x, y, info) result(z) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & z = x%v%minquotient(y%v,info) + + end function d_vect_minquotient_v + + module function d_vect_minquotient_a2(x, y, info) result(z) + implicit none + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: z + + info = 0 + z = x%v%minquotient(y,info) + + end function d_vect_minquotient_a2 + + + + module subroutine d_vect_addconst_a2(x,b,z,info) + implicit none + real(psb_dpk_), intent(in) :: b + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine d_vect_addconst_a2 + + module subroutine d_vect_addconst_v2(x,b,z,info) + + real(psb_dpk_), intent(in) :: b + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine d_vect_addconst_v2 + +end submodule psb_d_vect_impl + + +submodule (psb_d_multivect_mod) psb_d_multivect_impl + use psi_serial_mod + use psb_realloc_mod + +contains + + module function d_mvect_get_dupl(x) result(res) + implicit none + class(psb_d_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function d_mvect_get_dupl + + module subroutine d_mvect_set_dupl(x,val) + implicit none + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%dupl = val + else + x%dupl = psb_dupl_def_ + end if + end subroutine d_mvect_set_dupl + + + module function d_mvect_is_remote_build(x) result(res) + implicit none + class(psb_d_multivect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function d_mvect_is_remote_build + + module subroutine d_mvect_set_remote_build(x,val) + implicit none + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine d_mvect_set_remote_build + + + module subroutine psb_d_set_multivect_default(v) + implicit none + class(psb_d_base_multivect_type), intent(in) :: v + + if (allocated(psb_d_base_multivect_default)) then + deallocate(psb_d_base_multivect_default) + end if + allocate(psb_d_base_multivect_default, mold=v) + + end subroutine psb_d_set_multivect_default + + module function psb_d_get_multivect_default(v) result(res) + implicit none + class(psb_d_multivect_type), intent(in) :: v + class(psb_d_base_multivect_type), pointer :: res + + res => psb_d_get_base_multivect_default() + + end function psb_d_get_multivect_default + + + module function psb_d_get_base_multivect_default() result(res) + implicit none + class(psb_d_base_multivect_type), pointer :: res + + if (.not.allocated(psb_d_base_multivect_default)) then + allocate(psb_d_base_multivect_type :: psb_d_base_multivect_default) + end if + + res => psb_d_base_multivect_default + + end function psb_d_get_base_multivect_default + + + module subroutine d_mvect_clone(x,y,info) + implicit none + class(psb_d_multivect_type), intent(inout) :: x + class(psb_d_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld_x(x%get_vect(),mold=x%v) + end if + end subroutine d_mvect_clone + + module subroutine d_mvect_bld_x(x,invect,mold) + real(psb_dpk_), intent(in) :: invect(:,:) + class(psb_d_multivect_type), intent(out) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_d_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine d_mvect_bld_x + + + module subroutine d_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(out) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) + + end subroutine d_mvect_bld_n + + module function d_mvect_get_vect(x) result(res) + class(psb_d_multivect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function d_mvect_get_vect + + module subroutine d_mvect_set_scal(x,val) + class(psb_d_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine d_mvect_set_scal + + module subroutine d_mvect_set_vect(x,val) + class(psb_d_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine d_mvect_set_vect + + module function d_mvect_get_nrows(x) result(res) + implicit none + class(psb_d_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function d_mvect_get_nrows + + module function d_mvect_get_ncols(x) result(res) + implicit none + class(psb_d_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function d_mvect_get_ncols + + module function d_mvect_sizeof(x) result(res) + implicit none + class(psb_d_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function d_mvect_sizeof + + module function d_mvect_get_fmt(x) result(res) + implicit none + class(psb_d_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function d_mvect_get_fmt + + module subroutine d_mvect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(out) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_d_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine d_mvect_all + + module subroutine d_mvect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine d_mvect_reall + + module subroutine d_mvect_zero(x) + use psi_serial_mod + implicit none + class(psb_d_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine d_mvect_zero + + module subroutine d_mvect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine d_mvect_asb + + module subroutine d_mvect_sync(x) + implicit none + class(psb_d_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine d_mvect_sync + + module subroutine d_mvect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine d_mvect_gthab + + module subroutine d_mvect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine d_mvect_gthzv + + module subroutine d_mvect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: y(:) + class(psb_d_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine d_mvect_gthzv_x + + module subroutine d_mvect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine d_mvect_sctb + + module subroutine d_mvect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta, x(:) + class(psb_d_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine d_mvect_sctb_x + + module subroutine d_mvect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine d_mvect_free + + module subroutine d_mvect_ins(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine d_mvect_ins + + + module subroutine d_mvect_cnv(x,mold) + class(psb_d_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(in), optional :: mold + class(psb_d_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_d_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine d_mvect_cnv + + +!!$ module function d_mvect_dot_v(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_d_multivect_type), intent(inout) :: x, y +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ res = dzero +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & res = x%v%dot(n,y%v) +!!$ +!!$ end function d_mvect_dot_v +!!$ +!!$ module function d_mvect_dot_a(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ real(psb_dpk_), intent(in) :: y(:) +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ res = dzero +!!$ if (allocated(x%v)) & +!!$ & res = x%v%dot(n,y) +!!$ +!!$ end function d_mvect_dot_a +!!$ +!!$ module subroutine d_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ class(psb_d_multivect_type), intent(inout) :: y +!!$ real(psb_dpk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ call y%v%axpby(m,alpha,x%v,beta,info) +!!$ else +!!$ info = psb_err_invalid_mvect_state_ +!!$ end if +!!$ +!!$ end subroutine d_mvect_axpby_v +!!$ +!!$ module subroutine d_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ real(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_d_multivect_type), intent(inout) :: y +!!$ real(psb_dpk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(y%v)) & +!!$ & call y%v%axpby(m,alpha,x,beta,info) +!!$ +!!$ end subroutine d_mvect_axpby_a +!!$ +!!$ +!!$ module subroutine d_mvect_mlt_v(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ class(psb_d_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & call y%v%mlt(x%v,info) +!!$ +!!$ end subroutine d_mvect_mlt_v +!!$ +!!$ module subroutine d_mvect_mlt_a(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_d_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ +!!$ info = 0 +!!$ if (allocated(y%v)) & +!!$ & call y%v%mlt(x,info) +!!$ +!!$ end subroutine d_mvect_mlt_a +!!$ +!!$ +!!$ module subroutine d_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_dpk_), intent(in) :: alpha,beta +!!$ real(psb_dpk_), intent(in) :: y(:) +!!$ real(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_d_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x,y,beta,info) +!!$ +!!$ end subroutine d_mvect_mlt_a_2 +!!$ +!!$ module subroutine d_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_dpk_), intent(in) :: alpha,beta +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ class(psb_d_multivect_type), intent(inout) :: y +!!$ class(psb_d_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ character(len=1), intent(in), optional :: conjgx, conjgy +!!$ +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v).and.& +!!$ & allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) +!!$ +!!$ end subroutine d_mvect_mlt_v_2 +!!$ +!!$ module subroutine d_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_dpk_), intent(in) :: alpha,beta +!!$ real(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_d_multivect_type), intent(inout) :: y +!!$ class(psb_d_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v).and.allocated(y%v)) & +!!$ & call z%v%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine d_mvect_mlt_av +!!$ +!!$ module subroutine d_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_dpk_), intent(in) :: alpha,beta +!!$ real(psb_dpk_), intent(in) :: y(:) +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ class(psb_d_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ if (allocated(z%v).and.allocated(x%v)) & +!!$ & call z%v%mlt(alpha,x%v,y,beta,info) +!!$ +!!$ end subroutine d_mvect_mlt_va +!!$ +!!$ module subroutine d_mvect_scal(alpha, x) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ real(psb_dpk_), intent (in) :: alpha +!!$ +!!$ if (allocated(x%v)) call x%v%scal(alpha) +!!$ +!!$ end subroutine d_mvect_scal +!!$ +!!$ +!!$ module function d_mvect_nrm2(n,x) result(res) +!!$ implicit none +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%nrm2(n) +!!$ else +!!$ res = dzero +!!$ end if +!!$ +!!$ end function d_mvect_nrm2 +!!$ +!!$ module function d_mvect_amax(n,x) result(res) +!!$ implicit none +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%amax(n) +!!$ else +!!$ res = dzero +!!$ end if +!!$ +!!$ end function d_mvect_amax +!!$ +!!$ module function d_mvect_asum(n,x) result(res) +!!$ implicit none +!!$ class(psb_d_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%asum(n) +!!$ else +!!$ res = dzero +!!$ end if +!!$ +!!$ end function d_mvect_asum + +end submodule psb_d_multivect_impl + diff --git a/base/serial/impl/psb_i_vect_impl.F90 b/base/serial/impl/psb_i_vect_impl.F90 new file mode 100644 index 00000000..8f909cf7 --- /dev/null +++ b/base/serial/impl/psb_i_vect_impl.F90 @@ -0,0 +1,1051 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_i_vect_mod +! +! This module contains the definition of the psb_i_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +submodule (psb_i_vect_mod) psb_i_vect_impl + use psi_serial_mod + use psb_realloc_mod +contains + + module function i_vect_get_dupl(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_dupl() + else + res = psb_dupl_null_ + end if + end function i_vect_get_dupl + + module subroutine i_vect_set_dupl(x,val) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if + end if + end subroutine i_vect_set_dupl + + module function i_vect_get_ncfs(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function i_vect_get_ncfs + + module subroutine i_vect_set_ncfs(x,val) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine i_vect_set_ncfs + + module function i_vect_get_state(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function i_vect_get_state + + module function i_vect_is_null(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function i_vect_is_null + + module function i_vect_is_bld(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function i_vect_is_bld + + module function i_vect_is_upd(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function i_vect_is_upd + + module function i_vect_is_asb(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function i_vect_is_asb + + module subroutine i_vect_set_state(n,x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine i_vect_set_state + + + module subroutine i_vect_set_null(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine i_vect_set_null + + module subroutine i_vect_set_bld(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine i_vect_set_bld + + module subroutine i_vect_set_upd(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine i_vect_set_upd + + module subroutine i_vect_set_asb(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine i_vect_set_asb + + module 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 + + module 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 + + module function i_vect_is_remote_build(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function i_vect_is_remote_build + + module subroutine i_vect_set_remote_build(x,val) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine i_vect_set_remote_build + + module subroutine psb_i_set_vect_default(v) + implicit none + class(psb_i_base_vect_type), intent(in) :: v + + if (allocated(psb_i_base_vect_default)) then + deallocate(psb_i_base_vect_default) + end if + allocate(psb_i_base_vect_default, mold=v) + + end subroutine psb_i_set_vect_default + + module function psb_i_get_vect_default(v) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: v + class(psb_i_base_vect_type), pointer :: res + + res => psb_i_get_base_vect_default() + + end function psb_i_get_vect_default + + module subroutine psb_i_clear_vect_default() + implicit none + + if (allocated(psb_i_base_vect_default)) then + deallocate(psb_i_base_vect_default) + end if + + end subroutine psb_i_clear_vect_default + + module function psb_i_get_base_vect_default() result(res) + implicit none + class(psb_i_base_vect_type), pointer :: res + + if (.not.allocated(psb_i_base_vect_default)) then + allocate(psb_i_base_vect_type :: psb_i_base_vect_default) + end if + + res => psb_i_base_vect_default + + end function psb_i_get_base_vect_default + + module subroutine i_vect_clone(x,y,info) + implicit none + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + ! + ! Using sourced allocation here creates + ! problems with handling of memory allocated + ! elsewhere (e.g. accelerators), hence delegation + ! to %bld method + ! + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine i_vect_clone + + module subroutine i_vect_bld_x(x,invect,mold,scratch) + integer(psb_ipk_), intent(in) :: invect(:) + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) + + end subroutine i_vect_bld_x + + + module subroutine i_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + class(psb_i_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine i_vect_bld_mn + + module subroutine i_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine i_vect_bld_en + + module function i_vect_get_vect(x,n) result(res) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function i_vect_get_vect + + module subroutine i_vect_set_scal(x,val,first,last) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine i_vect_set_scal + + module subroutine i_vect_set_vect(x,val,first,last) + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine i_vect_set_vect + + module subroutine i_vect_check_addr(x) + class(psb_i_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%check_addr() + + end subroutine i_vect_check_addr + + module function i_vect_get_nrows(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function i_vect_get_nrows + + module function i_vect_sizeof(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function i_vect_sizeof + + module function i_vect_get_fmt(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function i_vect_get_fmt + + module 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 + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_i_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + call x%set_bld() + end subroutine i_vect_all + + module subroutine i_vect_reinit(x, info, clear) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + if (allocated(x%v)) call x%v%reinit(info,clear) + call x%set_upd() + + end subroutine i_vect_reinit + + module subroutine i_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine i_vect_reall + + module subroutine i_vect_zero(x) + + implicit none + class(psb_i_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine i_vect_zero + + module subroutine i_vect_asb(n, x, info, scratch) + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + if (allocated(x%v)) then + call x%v%asb(n,info,scratch=scratch) + call x%set_asb() + end if + end subroutine i_vect_asb + + module subroutine i_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine i_vect_gthab + + module subroutine i_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine i_vect_gthzv + + module subroutine i_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine i_vect_sctb + + module subroutine i_vect_free(x, info) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine i_vect_free + + module subroutine i_vect_ins_a(n,irl,val,x,maxr,info) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine i_vect_ins_a + + module subroutine i_vect_ins_v(n,irl,val,x,maxr,info) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + 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, 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,maxr,info) + + end subroutine i_vect_ins_v + + + module subroutine i_vect_cnv(x,mold) + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + class(psb_i_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_i_get_base_vect_default()) + end if + if (allocated(x%v)) then + if (allocated(x%v%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) + call x%v%free(info) + endif + end if + call move_alloc(tmp,x%v) + + end subroutine i_vect_cnv + + + module subroutine i_vect_sync(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine i_vect_sync + + module subroutine i_vect_set_sync(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine i_vect_set_sync + + module subroutine i_vect_set_host(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine i_vect_set_host + + module subroutine i_vect_set_dev(x) + implicit none + class(psb_i_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine i_vect_set_dev + + module function i_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_i_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function i_vect_is_sync + + module function i_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_i_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function i_vect_is_host + + module function i_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_i_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function i_vect_is_dev + + + + +end submodule psb_i_vect_impl + + +submodule (psb_i_multivect_mod) psb_i_multivect_impl + use psi_serial_mod + use psb_realloc_mod + +contains + + module function i_mvect_get_dupl(x) result(res) + implicit none + class(psb_i_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function i_mvect_get_dupl + + module subroutine i_mvect_set_dupl(x,val) + implicit none + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%dupl = val + else + x%dupl = psb_dupl_def_ + end if + end subroutine i_mvect_set_dupl + + + module function i_mvect_is_remote_build(x) result(res) + implicit none + class(psb_i_multivect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function i_mvect_is_remote_build + + module subroutine i_mvect_set_remote_build(x,val) + implicit none + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine i_mvect_set_remote_build + + + module subroutine psb_i_set_multivect_default(v) + implicit none + class(psb_i_base_multivect_type), intent(in) :: v + + if (allocated(psb_i_base_multivect_default)) then + deallocate(psb_i_base_multivect_default) + end if + allocate(psb_i_base_multivect_default, mold=v) + + end subroutine psb_i_set_multivect_default + + module function psb_i_get_multivect_default(v) result(res) + implicit none + class(psb_i_multivect_type), intent(in) :: v + class(psb_i_base_multivect_type), pointer :: res + + res => psb_i_get_base_multivect_default() + + end function psb_i_get_multivect_default + + + module function psb_i_get_base_multivect_default() result(res) + implicit none + class(psb_i_base_multivect_type), pointer :: res + + if (.not.allocated(psb_i_base_multivect_default)) then + allocate(psb_i_base_multivect_type :: psb_i_base_multivect_default) + end if + + res => psb_i_base_multivect_default + + end function psb_i_get_base_multivect_default + + + module subroutine i_mvect_clone(x,y,info) + implicit none + class(psb_i_multivect_type), intent(inout) :: x + class(psb_i_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld_x(x%get_vect(),mold=x%v) + end if + end subroutine i_mvect_clone + + module subroutine i_mvect_bld_x(x,invect,mold) + integer(psb_ipk_), intent(in) :: invect(:,:) + class(psb_i_multivect_type), intent(out) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_i_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine i_mvect_bld_x + + + module subroutine i_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(out) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) + + end subroutine i_mvect_bld_n + + module function i_mvect_get_vect(x) result(res) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function i_mvect_get_vect + + module subroutine i_mvect_set_scal(x,val) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine i_mvect_set_scal + + module subroutine i_mvect_set_vect(x,val) + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine i_mvect_set_vect + + module function i_mvect_get_nrows(x) result(res) + implicit none + class(psb_i_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function i_mvect_get_nrows + + module function i_mvect_get_ncols(x) result(res) + implicit none + class(psb_i_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function i_mvect_get_ncols + + module function i_mvect_sizeof(x) result(res) + implicit none + class(psb_i_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function i_mvect_sizeof + + module function i_mvect_get_fmt(x) result(res) + implicit none + class(psb_i_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function i_mvect_get_fmt + + module subroutine i_mvect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(out) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_i_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine i_mvect_all + + module subroutine i_mvect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine i_mvect_reall + + module subroutine i_mvect_zero(x) + use psi_serial_mod + implicit none + class(psb_i_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine i_mvect_zero + + module subroutine i_mvect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine i_mvect_asb + + module subroutine i_mvect_sync(x) + implicit none + class(psb_i_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine i_mvect_sync + + module subroutine i_mvect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine i_mvect_gthab + + module subroutine i_mvect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine i_mvect_gthzv + + module subroutine i_mvect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: y(:) + class(psb_i_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine i_mvect_gthzv_x + + module subroutine i_mvect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine i_mvect_sctb + + module subroutine i_mvect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta, x(:) + class(psb_i_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine i_mvect_sctb_x + + module subroutine i_mvect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine i_mvect_free + + module subroutine i_mvect_ins(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine i_mvect_ins + + + module subroutine i_mvect_cnv(x,mold) + class(psb_i_multivect_type), intent(inout) :: x + class(psb_i_base_multivect_type), intent(in), optional :: mold + class(psb_i_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_i_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine i_mvect_cnv + + +end submodule psb_i_multivect_impl + diff --git a/base/serial/impl/psb_l_vect_impl.F90 b/base/serial/impl/psb_l_vect_impl.F90 new file mode 100644 index 00000000..31d5ec33 --- /dev/null +++ b/base/serial/impl/psb_l_vect_impl.F90 @@ -0,0 +1,1051 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_l_vect_mod +! +! This module contains the definition of the psb_l_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +submodule (psb_l_vect_mod) psb_l_vect_impl + use psi_serial_mod + use psb_realloc_mod +contains + + module function l_vect_get_dupl(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_dupl() + else + res = psb_dupl_null_ + end if + end function l_vect_get_dupl + + module subroutine l_vect_set_dupl(x,val) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if + end if + end subroutine l_vect_set_dupl + + module function l_vect_get_ncfs(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function l_vect_get_ncfs + + module subroutine l_vect_set_ncfs(x,val) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine l_vect_set_ncfs + + module function l_vect_get_state(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function l_vect_get_state + + module function l_vect_is_null(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function l_vect_is_null + + module function l_vect_is_bld(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function l_vect_is_bld + + module function l_vect_is_upd(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function l_vect_is_upd + + module function l_vect_is_asb(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function l_vect_is_asb + + module subroutine l_vect_set_state(n,x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine l_vect_set_state + + + module subroutine l_vect_set_null(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine l_vect_set_null + + module subroutine l_vect_set_bld(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine l_vect_set_bld + + module subroutine l_vect_set_upd(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine l_vect_set_upd + + module subroutine l_vect_set_asb(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine l_vect_set_asb + + module 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 + + module 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 + + module function l_vect_is_remote_build(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function l_vect_is_remote_build + + module subroutine l_vect_set_remote_build(x,val) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine l_vect_set_remote_build + + module subroutine psb_l_set_vect_default(v) + implicit none + class(psb_l_base_vect_type), intent(in) :: v + + if (allocated(psb_l_base_vect_default)) then + deallocate(psb_l_base_vect_default) + end if + allocate(psb_l_base_vect_default, mold=v) + + end subroutine psb_l_set_vect_default + + module function psb_l_get_vect_default(v) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: v + class(psb_l_base_vect_type), pointer :: res + + res => psb_l_get_base_vect_default() + + end function psb_l_get_vect_default + + module subroutine psb_l_clear_vect_default() + implicit none + + if (allocated(psb_l_base_vect_default)) then + deallocate(psb_l_base_vect_default) + end if + + end subroutine psb_l_clear_vect_default + + module function psb_l_get_base_vect_default() result(res) + implicit none + class(psb_l_base_vect_type), pointer :: res + + if (.not.allocated(psb_l_base_vect_default)) then + allocate(psb_l_base_vect_type :: psb_l_base_vect_default) + end if + + res => psb_l_base_vect_default + + end function psb_l_get_base_vect_default + + module subroutine l_vect_clone(x,y,info) + implicit none + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + ! + ! Using sourced allocation here creates + ! problems with handling of memory allocated + ! elsewhere (e.g. accelerators), hence delegation + ! to %bld method + ! + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine l_vect_clone + + module subroutine l_vect_bld_x(x,invect,mold,scratch) + integer(psb_lpk_), intent(in) :: invect(:) + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) + + end subroutine l_vect_bld_x + + + module subroutine l_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + class(psb_l_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine l_vect_bld_mn + + module subroutine l_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine l_vect_bld_en + + module function l_vect_get_vect(x,n) result(res) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function l_vect_get_vect + + module subroutine l_vect_set_scal(x,val,first,last) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine l_vect_set_scal + + module subroutine l_vect_set_vect(x,val,first,last) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine l_vect_set_vect + + module subroutine l_vect_check_addr(x) + class(psb_l_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%check_addr() + + end subroutine l_vect_check_addr + + module function l_vect_get_nrows(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function l_vect_get_nrows + + module function l_vect_sizeof(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function l_vect_sizeof + + module function l_vect_get_fmt(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function l_vect_get_fmt + + module 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 + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_l_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + call x%set_bld() + end subroutine l_vect_all + + module subroutine l_vect_reinit(x, info, clear) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + if (allocated(x%v)) call x%v%reinit(info,clear) + call x%set_upd() + + end subroutine l_vect_reinit + + module subroutine l_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine l_vect_reall + + module subroutine l_vect_zero(x) + + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine l_vect_zero + + module subroutine l_vect_asb(n, x, info, scratch) + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + if (allocated(x%v)) then + call x%v%asb(n,info,scratch=scratch) + call x%set_asb() + end if + end subroutine l_vect_asb + + module subroutine l_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine l_vect_gthab + + module subroutine l_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine l_vect_gthzv + + module subroutine l_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine l_vect_sctb + + module subroutine l_vect_free(x, info) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine l_vect_free + + module subroutine l_vect_ins_a(n,irl,val,x,maxr,info) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine l_vect_ins_a + + module subroutine l_vect_ins_v(n,irl,val,x,maxr,info) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + 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, 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,maxr,info) + + end subroutine l_vect_ins_v + + + module subroutine l_vect_cnv(x,mold) + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + class(psb_l_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_l_get_base_vect_default()) + end if + if (allocated(x%v)) then + if (allocated(x%v%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) + call x%v%free(info) + endif + end if + call move_alloc(tmp,x%v) + + end subroutine l_vect_cnv + + + module subroutine l_vect_sync(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine l_vect_sync + + module subroutine l_vect_set_sync(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine l_vect_set_sync + + module subroutine l_vect_set_host(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine l_vect_set_host + + module subroutine l_vect_set_dev(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine l_vect_set_dev + + module function l_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_l_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function l_vect_is_sync + + module function l_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_l_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function l_vect_is_host + + module function l_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_l_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function l_vect_is_dev + + + + +end submodule psb_l_vect_impl + + +submodule (psb_l_multivect_mod) psb_l_multivect_impl + use psi_serial_mod + use psb_realloc_mod + +contains + + module function l_mvect_get_dupl(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function l_mvect_get_dupl + + module subroutine l_mvect_set_dupl(x,val) + implicit none + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%dupl = val + else + x%dupl = psb_dupl_def_ + end if + end subroutine l_mvect_set_dupl + + + module function l_mvect_is_remote_build(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function l_mvect_is_remote_build + + module subroutine l_mvect_set_remote_build(x,val) + implicit none + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine l_mvect_set_remote_build + + + module subroutine psb_l_set_multivect_default(v) + implicit none + class(psb_l_base_multivect_type), intent(in) :: v + + if (allocated(psb_l_base_multivect_default)) then + deallocate(psb_l_base_multivect_default) + end if + allocate(psb_l_base_multivect_default, mold=v) + + end subroutine psb_l_set_multivect_default + + module function psb_l_get_multivect_default(v) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: v + class(psb_l_base_multivect_type), pointer :: res + + res => psb_l_get_base_multivect_default() + + end function psb_l_get_multivect_default + + + module function psb_l_get_base_multivect_default() result(res) + implicit none + class(psb_l_base_multivect_type), pointer :: res + + if (.not.allocated(psb_l_base_multivect_default)) then + allocate(psb_l_base_multivect_type :: psb_l_base_multivect_default) + end if + + res => psb_l_base_multivect_default + + end function psb_l_get_base_multivect_default + + + module subroutine l_mvect_clone(x,y,info) + implicit none + class(psb_l_multivect_type), intent(inout) :: x + class(psb_l_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld_x(x%get_vect(),mold=x%v) + end if + end subroutine l_mvect_clone + + module subroutine l_mvect_bld_x(x,invect,mold) + integer(psb_lpk_), intent(in) :: invect(:,:) + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_l_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine l_mvect_bld_x + + + module subroutine l_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) + + end subroutine l_mvect_bld_n + + module function l_mvect_get_vect(x) result(res) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function l_mvect_get_vect + + module subroutine l_mvect_set_scal(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine l_mvect_set_scal + + module subroutine l_mvect_set_vect(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine l_mvect_set_vect + + module function l_mvect_get_nrows(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function l_mvect_get_nrows + + module function l_mvect_get_ncols(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function l_mvect_get_ncols + + module function l_mvect_sizeof(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function l_mvect_sizeof + + module function l_mvect_get_fmt(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function l_mvect_get_fmt + + module subroutine l_mvect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_l_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine l_mvect_all + + module subroutine l_mvect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine l_mvect_reall + + module subroutine l_mvect_zero(x) + use psi_serial_mod + implicit none + class(psb_l_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine l_mvect_zero + + module subroutine l_mvect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine l_mvect_asb + + module subroutine l_mvect_sync(x) + implicit none + class(psb_l_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine l_mvect_sync + + module subroutine l_mvect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine l_mvect_gthab + + module subroutine l_mvect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine l_mvect_gthzv + + module subroutine l_mvect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: y(:) + class(psb_l_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine l_mvect_gthzv_x + + module subroutine l_mvect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine l_mvect_sctb + + module subroutine l_mvect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta, x(:) + class(psb_l_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine l_mvect_sctb_x + + module subroutine l_mvect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine l_mvect_free + + module subroutine l_mvect_ins(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine l_mvect_ins + + + module subroutine l_mvect_cnv(x,mold) + class(psb_l_multivect_type), intent(inout) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + class(psb_l_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_l_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine l_mvect_cnv + + +end submodule psb_l_multivect_impl + diff --git a/base/serial/impl/psb_s_vect_impl.F90 b/base/serial/impl/psb_s_vect_impl.F90 new file mode 100644 index 00000000..3e2ec09b --- /dev/null +++ b/base/serial/impl/psb_s_vect_impl.F90 @@ -0,0 +1,1911 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_s_vect_mod +! +! This module contains the definition of the psb_s_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +submodule (psb_s_vect_mod) psb_s_vect_impl + use psi_serial_mod + use psb_realloc_mod +contains + + module function s_vect_get_dupl(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_dupl() + else + res = psb_dupl_null_ + end if + end function s_vect_get_dupl + + module subroutine s_vect_set_dupl(x,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if + end if + end subroutine s_vect_set_dupl + + module function s_vect_get_ncfs(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function s_vect_get_ncfs + + module subroutine s_vect_set_ncfs(x,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine s_vect_set_ncfs + + module function s_vect_get_state(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function s_vect_get_state + + module function s_vect_is_null(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function s_vect_is_null + + module function s_vect_is_bld(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function s_vect_is_bld + + module function s_vect_is_upd(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function s_vect_is_upd + + module function s_vect_is_asb(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function s_vect_is_asb + + module subroutine s_vect_set_state(n,x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine s_vect_set_state + + + module subroutine s_vect_set_null(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine s_vect_set_null + + module subroutine s_vect_set_bld(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine s_vect_set_bld + + module subroutine s_vect_set_upd(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine s_vect_set_upd + + module subroutine s_vect_set_asb(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine s_vect_set_asb + + module 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 + + module 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 + + module function s_vect_is_remote_build(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function s_vect_is_remote_build + + module subroutine s_vect_set_remote_build(x,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine s_vect_set_remote_build + + module subroutine psb_s_set_vect_default(v) + implicit none + class(psb_s_base_vect_type), intent(in) :: v + + if (allocated(psb_s_base_vect_default)) then + deallocate(psb_s_base_vect_default) + end if + allocate(psb_s_base_vect_default, mold=v) + + end subroutine psb_s_set_vect_default + + module function psb_s_get_vect_default(v) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: v + class(psb_s_base_vect_type), pointer :: res + + res => psb_s_get_base_vect_default() + + end function psb_s_get_vect_default + + module subroutine psb_s_clear_vect_default() + implicit none + + if (allocated(psb_s_base_vect_default)) then + deallocate(psb_s_base_vect_default) + end if + + end subroutine psb_s_clear_vect_default + + module function psb_s_get_base_vect_default() result(res) + implicit none + class(psb_s_base_vect_type), pointer :: res + + if (.not.allocated(psb_s_base_vect_default)) then + allocate(psb_s_base_vect_type :: psb_s_base_vect_default) + end if + + res => psb_s_base_vect_default + + end function psb_s_get_base_vect_default + + module subroutine s_vect_clone(x,y,info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + ! + ! Using sourced allocation here creates + ! problems with handling of memory allocated + ! elsewhere (e.g. accelerators), hence delegation + ! to %bld method + ! + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine s_vect_clone + + module subroutine s_vect_bld_x(x,invect,mold,scratch) + real(psb_spk_), intent(in) :: invect(:) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) + + end subroutine s_vect_bld_x + + + module subroutine s_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + class(psb_s_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine s_vect_bld_mn + + module subroutine s_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine s_vect_bld_en + + module function s_vect_get_vect(x,n) result(res) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function s_vect_get_vect + + module subroutine s_vect_set_scal(x,val,first,last) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine s_vect_set_scal + + module subroutine s_vect_set_vect(x,val,first,last) + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine s_vect_set_vect + + module subroutine s_vect_check_addr(x) + class(psb_s_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%check_addr() + + end subroutine s_vect_check_addr + + module function s_vect_get_nrows(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function s_vect_get_nrows + + module function s_vect_sizeof(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function s_vect_sizeof + + module function s_vect_get_fmt(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function s_vect_get_fmt + + module 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 + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_s_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + call x%set_bld() + end subroutine s_vect_all + + module subroutine s_vect_reinit(x, info, clear) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + if (allocated(x%v)) call x%v%reinit(info,clear) + call x%set_upd() + + end subroutine s_vect_reinit + + module subroutine s_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine s_vect_reall + + module subroutine s_vect_zero(x) + + implicit none + class(psb_s_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine s_vect_zero + + module subroutine s_vect_asb(n, x, info, scratch) + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + if (allocated(x%v)) then + call x%v%asb(n,info,scratch=scratch) + call x%set_asb() + end if + end subroutine s_vect_asb + + module subroutine s_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine s_vect_gthab + + module subroutine s_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine s_vect_gthzv + + module subroutine s_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine s_vect_sctb + + module subroutine s_vect_free(x, info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine s_vect_free + + module subroutine s_vect_ins_a(n,irl,val,x,maxr,info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine s_vect_ins_a + + module subroutine s_vect_ins_v(n,irl,val,x,maxr,info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + 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, 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,maxr,info) + + end subroutine s_vect_ins_v + + + module subroutine s_vect_cnv(x,mold) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + class(psb_s_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_s_get_base_vect_default()) + end if + if (allocated(x%v)) then + if (allocated(x%v%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) + call x%v%free(info) + endif + end if + call move_alloc(tmp,x%v) + + end subroutine s_vect_cnv + + + module subroutine s_vect_sync(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine s_vect_sync + + module subroutine s_vect_set_sync(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine s_vect_set_sync + + module subroutine s_vect_set_host(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine s_vect_set_host + + module subroutine s_vect_set_dev(x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine s_vect_set_dev + + module function s_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_s_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function s_vect_is_sync + + module function s_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_s_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function s_vect_is_host + + module function s_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_s_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function s_vect_is_dev + + + module function s_vect_get_entry(x,index) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: res + res = szero + if (allocated(x%v)) res = x%v%get_entry(index) + end function s_vect_get_entry + + module subroutine s_vect_set_entry(x,index,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine s_vect_set_entry + + module function s_vect_dot_v(n,x,y) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + res = szero + if (allocated(x%v).and.allocated(y%v)) & + & res = x%v%dot(n,y%v) + + end function s_vect_dot_v + + module function s_vect_dot_a(n,x,y) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + res = szero + if (allocated(x%v)) & + & res = x%v%dot_a(n,y) + + end function s_vect_dot_a + + module subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call y%v%axpby(m,alpha,x%v,beta,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine s_vect_axpby_v + + module subroutine s_vect_axpby_v2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine s_vect_axpby_v2 + + module subroutine s_vect_axpby_a(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(y%v)) & + & call y%v%axpby(m,alpha,x,beta,info) + + end subroutine s_vect_axpby_a + + module subroutine s_vect_axpby_a2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine s_vect_axpby_a2 + + module subroutine s_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) + + end subroutine s_vect_upd_xyz + + module subroutine s_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + class(psb_s_vect_type), intent(inout) :: w + real(psb_spk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + + if (allocated(w%v)) & + call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) + + end subroutine s_vect_xyzw + + + module subroutine s_vect_mlt_v(x, y, info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%mlt(x%v,info) + + end subroutine s_vect_mlt_v + + module subroutine s_vect_mlt_a(x, y, info) + implicit none + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + + info = 0 + if (allocated(y%v)) & + & call y%v%mlt(x,info) + + end subroutine s_vect_mlt_a + + + module subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info) + implicit none + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: y(:) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%mlt(alpha,x,y,beta,info) + + end subroutine s_vect_mlt_a_2 + + module subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + implicit none + real(psb_spk_), intent(in) :: alpha,beta + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.& + & allocated(z%v)) & + & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) + + end subroutine s_vect_mlt_v_2 + + module subroutine s_vect_mlt_av(alpha,x,y,beta,z,info) + implicit none + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v).and.allocated(y%v)) & + & call z%v%mlt(alpha,x,y%v,beta,info) + + end subroutine s_vect_mlt_av + + module subroutine s_vect_mlt_va(alpha,x,y,beta,z,info) + implicit none + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + + if (allocated(z%v).and.allocated(x%v)) & + & call z%v%mlt(alpha,x%v,y,beta,info) + + end subroutine s_vect_mlt_va + + module subroutine s_vect_div_v(x, y, info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine s_vect_div_v + + module subroutine s_vect_div_v2( x, y, z, info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine s_vect_div_v2 + + module subroutine s_vect_div_v_check(x, y, info, flag) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine s_vect_div_v_check + + module subroutine s_vect_div_v2_check(x, y, z, info, flag) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine s_vect_div_v2_check + + module subroutine s_vect_div_a2(x, y, z, info) + implicit none + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine s_vect_div_a2 + + module subroutine s_vect_div_a2_check(x, y, z, info,flag) + implicit none + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine s_vect_div_a2_check + + module subroutine s_vect_inv_v(x, y, info) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine s_vect_inv_v + + module subroutine s_vect_inv_v_check(x, y, info, flag) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine s_vect_inv_v_check + + module subroutine s_vect_inv_a2(x, y, info) + implicit none + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine s_vect_inv_a2 + + module subroutine s_vect_inv_a2_check(x, y, info,flag) + + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine s_vect_inv_a2_check + + module subroutine s_vect_acmp_a2(x,c,z,info) + implicit none + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine s_vect_acmp_a2 + + module subroutine s_vect_acmp_v2(x,c,z,info) + implicit none + real(psb_spk_), intent(in) :: c + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine s_vect_acmp_v2 + + module subroutine s_vect_scal(alpha, x) + implicit none + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent (in) :: alpha + + if (allocated(x%v)) call x%v%scal(alpha) + + end subroutine s_vect_scal + + module subroutine s_vect_absval1(x) + class(psb_s_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%absval() + + end subroutine s_vect_absval1 + + module subroutine s_vect_absval2(x,y) + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + + if (allocated(x%v)) then + if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) + call x%v%absval(y%v) + end if + end subroutine s_vect_absval2 + + module function s_vect_nrm2(n,x) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then + res = x%v%nrm2(n) + else + res = szero + end if + + end function s_vect_nrm2 + + module function s_vect_nrm2_weight(n,x,w,aux) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: w + class(psb_s_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: info + + ! Temp vectors + type(psb_s_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,sone,w%v%v,szero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -sone + return + end if + + if (allocated(x%v)) then + if (.not.present(aux)) then + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = szero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function s_vect_nrm2_weight + + module function s_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: w + class(psb_s_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_s_vect_type), intent(inout), optional :: aux + + ! Temp vectors + type(psb_s_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,sone,w%v%v,szero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -sone + return + end if + + + if (allocated(x%v).and.allocated(id%v)) then + if (.not.present(aux)) then + where( abs(id%v%v) <= szero) wtemp%v%v = szero + call wtemp%set_host() + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + where( abs(id%v%v) <= szero) aux%v%v = szero + call aux%set_host() + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = szero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function s_vect_nrm2_weight_mask + + module function s_vect_amax(n,x) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then + res = x%v%amax(n) + else + res = szero + end if + + end function s_vect_amax + + module function s_vect_min(n,x) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then + res = x%v%minreal(n) + else + res = HUGE(szero) + end if + + end function s_vect_min + + module function s_vect_asum(n,x) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then + res = x%v%asum(n) + else + res = szero + end if + + end function s_vect_asum + + + module subroutine s_vect_mask_a(c,x,m,t,info) + implicit none + real(psb_spk_), intent(inout) :: c(:) + real(psb_spk_), intent(inout) :: x(:) + logical, intent(out) :: t; + class(psb_s_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(m%v)) & + & call m%mask(c,x,t,info) + + end subroutine s_vect_mask_a + + module subroutine s_vect_mask_v(c,x,m,t,info) + implicit none + class(psb_s_vect_type), intent(inout) :: c + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: m + logical, intent(out) :: t; + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(c%v)) & + & call m%v%mask(x%v,c%v,t,info) + + end subroutine s_vect_mask_v + + module function s_vect_minquotient_v(x, y, info) result(z) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & z = x%v%minquotient(y%v,info) + + end function s_vect_minquotient_v + + module function s_vect_minquotient_a2(x, y, info) result(z) + implicit none + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: z + + info = 0 + z = x%v%minquotient(y,info) + + end function s_vect_minquotient_a2 + + + + module subroutine s_vect_addconst_a2(x,b,z,info) + implicit none + real(psb_spk_), intent(in) :: b + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine s_vect_addconst_a2 + + module subroutine s_vect_addconst_v2(x,b,z,info) + + real(psb_spk_), intent(in) :: b + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine s_vect_addconst_v2 + +end submodule psb_s_vect_impl + + +submodule (psb_s_multivect_mod) psb_s_multivect_impl + use psi_serial_mod + use psb_realloc_mod + +contains + + module function s_mvect_get_dupl(x) result(res) + implicit none + class(psb_s_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function s_mvect_get_dupl + + module subroutine s_mvect_set_dupl(x,val) + implicit none + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%dupl = val + else + x%dupl = psb_dupl_def_ + end if + end subroutine s_mvect_set_dupl + + + module function s_mvect_is_remote_build(x) result(res) + implicit none + class(psb_s_multivect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function s_mvect_is_remote_build + + module subroutine s_mvect_set_remote_build(x,val) + implicit none + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine s_mvect_set_remote_build + + + module subroutine psb_s_set_multivect_default(v) + implicit none + class(psb_s_base_multivect_type), intent(in) :: v + + if (allocated(psb_s_base_multivect_default)) then + deallocate(psb_s_base_multivect_default) + end if + allocate(psb_s_base_multivect_default, mold=v) + + end subroutine psb_s_set_multivect_default + + module function psb_s_get_multivect_default(v) result(res) + implicit none + class(psb_s_multivect_type), intent(in) :: v + class(psb_s_base_multivect_type), pointer :: res + + res => psb_s_get_base_multivect_default() + + end function psb_s_get_multivect_default + + + module function psb_s_get_base_multivect_default() result(res) + implicit none + class(psb_s_base_multivect_type), pointer :: res + + if (.not.allocated(psb_s_base_multivect_default)) then + allocate(psb_s_base_multivect_type :: psb_s_base_multivect_default) + end if + + res => psb_s_base_multivect_default + + end function psb_s_get_base_multivect_default + + + module subroutine s_mvect_clone(x,y,info) + implicit none + class(psb_s_multivect_type), intent(inout) :: x + class(psb_s_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld_x(x%get_vect(),mold=x%v) + end if + end subroutine s_mvect_clone + + module subroutine s_mvect_bld_x(x,invect,mold) + real(psb_spk_), intent(in) :: invect(:,:) + class(psb_s_multivect_type), intent(out) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_s_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine s_mvect_bld_x + + + module subroutine s_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(out) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) + + end subroutine s_mvect_bld_n + + module function s_mvect_get_vect(x) result(res) + class(psb_s_multivect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function s_mvect_get_vect + + module subroutine s_mvect_set_scal(x,val) + class(psb_s_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine s_mvect_set_scal + + module subroutine s_mvect_set_vect(x,val) + class(psb_s_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine s_mvect_set_vect + + module function s_mvect_get_nrows(x) result(res) + implicit none + class(psb_s_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function s_mvect_get_nrows + + module function s_mvect_get_ncols(x) result(res) + implicit none + class(psb_s_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function s_mvect_get_ncols + + module function s_mvect_sizeof(x) result(res) + implicit none + class(psb_s_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function s_mvect_sizeof + + module function s_mvect_get_fmt(x) result(res) + implicit none + class(psb_s_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function s_mvect_get_fmt + + module subroutine s_mvect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(out) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_s_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine s_mvect_all + + module subroutine s_mvect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine s_mvect_reall + + module subroutine s_mvect_zero(x) + use psi_serial_mod + implicit none + class(psb_s_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine s_mvect_zero + + module subroutine s_mvect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine s_mvect_asb + + module subroutine s_mvect_sync(x) + implicit none + class(psb_s_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine s_mvect_sync + + module subroutine s_mvect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine s_mvect_gthab + + module subroutine s_mvect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine s_mvect_gthzv + + module subroutine s_mvect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: y(:) + class(psb_s_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine s_mvect_gthzv_x + + module subroutine s_mvect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine s_mvect_sctb + + module subroutine s_mvect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta, x(:) + class(psb_s_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine s_mvect_sctb_x + + module subroutine s_mvect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine s_mvect_free + + module subroutine s_mvect_ins(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine s_mvect_ins + + + module subroutine s_mvect_cnv(x,mold) + class(psb_s_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(in), optional :: mold + class(psb_s_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_s_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine s_mvect_cnv + + +!!$ module function s_mvect_dot_v(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_s_multivect_type), intent(inout) :: x, y +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ res = szero +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & res = x%v%dot(n,y%v) +!!$ +!!$ end function s_mvect_dot_v +!!$ +!!$ module function s_mvect_dot_a(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ real(psb_spk_), intent(in) :: y(:) +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ res = szero +!!$ if (allocated(x%v)) & +!!$ & res = x%v%dot(n,y) +!!$ +!!$ end function s_mvect_dot_a +!!$ +!!$ module subroutine s_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ class(psb_s_multivect_type), intent(inout) :: y +!!$ real(psb_spk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ call y%v%axpby(m,alpha,x%v,beta,info) +!!$ else +!!$ info = psb_err_invalid_mvect_state_ +!!$ end if +!!$ +!!$ end subroutine s_mvect_axpby_v +!!$ +!!$ module subroutine s_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ real(psb_spk_), intent(in) :: x(:) +!!$ class(psb_s_multivect_type), intent(inout) :: y +!!$ real(psb_spk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(y%v)) & +!!$ & call y%v%axpby(m,alpha,x,beta,info) +!!$ +!!$ end subroutine s_mvect_axpby_a +!!$ +!!$ +!!$ module subroutine s_mvect_mlt_v(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ class(psb_s_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & call y%v%mlt(x%v,info) +!!$ +!!$ end subroutine s_mvect_mlt_v +!!$ +!!$ module subroutine s_mvect_mlt_a(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_spk_), intent(in) :: x(:) +!!$ class(psb_s_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ +!!$ info = 0 +!!$ if (allocated(y%v)) & +!!$ & call y%v%mlt(x,info) +!!$ +!!$ end subroutine s_mvect_mlt_a +!!$ +!!$ +!!$ module subroutine s_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_spk_), intent(in) :: alpha,beta +!!$ real(psb_spk_), intent(in) :: y(:) +!!$ real(psb_spk_), intent(in) :: x(:) +!!$ class(psb_s_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x,y,beta,info) +!!$ +!!$ end subroutine s_mvect_mlt_a_2 +!!$ +!!$ module subroutine s_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_spk_), intent(in) :: alpha,beta +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ class(psb_s_multivect_type), intent(inout) :: y +!!$ class(psb_s_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ character(len=1), intent(in), optional :: conjgx, conjgy +!!$ +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v).and.& +!!$ & allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) +!!$ +!!$ end subroutine s_mvect_mlt_v_2 +!!$ +!!$ module subroutine s_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_spk_), intent(in) :: alpha,beta +!!$ real(psb_spk_), intent(in) :: x(:) +!!$ class(psb_s_multivect_type), intent(inout) :: y +!!$ class(psb_s_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v).and.allocated(y%v)) & +!!$ & call z%v%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine s_mvect_mlt_av +!!$ +!!$ module subroutine s_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ real(psb_spk_), intent(in) :: alpha,beta +!!$ real(psb_spk_), intent(in) :: y(:) +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ class(psb_s_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ if (allocated(z%v).and.allocated(x%v)) & +!!$ & call z%v%mlt(alpha,x%v,y,beta,info) +!!$ +!!$ end subroutine s_mvect_mlt_va +!!$ +!!$ module subroutine s_mvect_scal(alpha, x) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ real(psb_spk_), intent (in) :: alpha +!!$ +!!$ if (allocated(x%v)) call x%v%scal(alpha) +!!$ +!!$ end subroutine s_mvect_scal +!!$ +!!$ +!!$ module function s_mvect_nrm2(n,x) result(res) +!!$ implicit none +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%nrm2(n) +!!$ else +!!$ res = szero +!!$ end if +!!$ +!!$ end function s_mvect_nrm2 +!!$ +!!$ module function s_mvect_amax(n,x) result(res) +!!$ implicit none +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%amax(n) +!!$ else +!!$ res = szero +!!$ end if +!!$ +!!$ end function s_mvect_amax +!!$ +!!$ module function s_mvect_asum(n,x) result(res) +!!$ implicit none +!!$ class(psb_s_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_spk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%asum(n) +!!$ else +!!$ res = szero +!!$ end if +!!$ +!!$ end function s_mvect_asum + +end submodule psb_s_multivect_impl + diff --git a/base/serial/impl/psb_z_vect_impl.F90 b/base/serial/impl/psb_z_vect_impl.F90 new file mode 100644 index 00000000..c342cfed --- /dev/null +++ b/base/serial/impl/psb_z_vect_impl.F90 @@ -0,0 +1,1843 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_z_vect_mod +! +! This module contains the definition of the psb_z_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +submodule (psb_z_vect_mod) psb_z_vect_impl + use psi_serial_mod + use psb_realloc_mod +contains + + module function z_vect_get_dupl(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_dupl() + else + res = psb_dupl_null_ + end if + end function z_vect_get_dupl + + module subroutine z_vect_set_dupl(x,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if + end if + end subroutine z_vect_set_dupl + + module function z_vect_get_ncfs(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function z_vect_get_ncfs + + module subroutine z_vect_set_ncfs(x,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine z_vect_set_ncfs + + module function z_vect_get_state(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function z_vect_get_state + + module function z_vect_is_null(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function z_vect_is_null + + module function z_vect_is_bld(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function z_vect_is_bld + + module function z_vect_is_upd(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function z_vect_is_upd + + module function z_vect_is_asb(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function z_vect_is_asb + + module subroutine z_vect_set_state(n,x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine z_vect_set_state + + + module subroutine z_vect_set_null(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine z_vect_set_null + + module subroutine z_vect_set_bld(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine z_vect_set_bld + + module subroutine z_vect_set_upd(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine z_vect_set_upd + + module subroutine z_vect_set_asb(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine z_vect_set_asb + + module 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 + + module 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 + + module function z_vect_is_remote_build(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function z_vect_is_remote_build + + module subroutine z_vect_set_remote_build(x,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine z_vect_set_remote_build + + module subroutine psb_z_set_vect_default(v) + implicit none + class(psb_z_base_vect_type), intent(in) :: v + + if (allocated(psb_z_base_vect_default)) then + deallocate(psb_z_base_vect_default) + end if + allocate(psb_z_base_vect_default, mold=v) + + end subroutine psb_z_set_vect_default + + module function psb_z_get_vect_default(v) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: v + class(psb_z_base_vect_type), pointer :: res + + res => psb_z_get_base_vect_default() + + end function psb_z_get_vect_default + + module subroutine psb_z_clear_vect_default() + implicit none + + if (allocated(psb_z_base_vect_default)) then + deallocate(psb_z_base_vect_default) + end if + + end subroutine psb_z_clear_vect_default + + module function psb_z_get_base_vect_default() result(res) + implicit none + class(psb_z_base_vect_type), pointer :: res + + if (.not.allocated(psb_z_base_vect_default)) then + allocate(psb_z_base_vect_type :: psb_z_base_vect_default) + end if + + res => psb_z_base_vect_default + + end function psb_z_get_base_vect_default + + module subroutine z_vect_clone(x,y,info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + ! + ! Using sourced allocation here creates + ! problems with handling of memory allocated + ! elsewhere (e.g. accelerators), hence delegation + ! to %bld method + ! + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine z_vect_clone + + module subroutine z_vect_bld_x(x,invect,mold,scratch) + complex(psb_dpk_), intent(in) :: invect(:) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) + + end subroutine z_vect_bld_x + + + module subroutine z_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + class(psb_z_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine z_vect_bld_mn + + module subroutine z_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine z_vect_bld_en + + module function z_vect_get_vect(x,n) result(res) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function z_vect_get_vect + + module subroutine z_vect_set_scal(x,val,first,last) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine z_vect_set_scal + + module subroutine z_vect_set_vect(x,val,first,last) + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine z_vect_set_vect + + module subroutine z_vect_check_addr(x) + class(psb_z_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%check_addr() + + end subroutine z_vect_check_addr + + module function z_vect_get_nrows(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function z_vect_get_nrows + + module function z_vect_sizeof(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function z_vect_sizeof + + module function z_vect_get_fmt(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function z_vect_get_fmt + + module 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 + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_z_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + call x%set_bld() + end subroutine z_vect_all + + module subroutine z_vect_reinit(x, info, clear) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + if (allocated(x%v)) call x%v%reinit(info,clear) + call x%set_upd() + + end subroutine z_vect_reinit + + module subroutine z_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine z_vect_reall + + module subroutine z_vect_zero(x) + + implicit none + class(psb_z_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine z_vect_zero + + module subroutine z_vect_asb(n, x, info, scratch) + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + if (allocated(x%v)) then + call x%v%asb(n,info,scratch=scratch) + call x%set_asb() + end if + end subroutine z_vect_asb + + module subroutine z_vect_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine z_vect_gthab + + module subroutine z_vect_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine z_vect_gthzv + + module subroutine z_vect_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine z_vect_sctb + + module subroutine z_vect_free(x, info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine z_vect_free + + module subroutine z_vect_ins_a(n,irl,val,x,maxr,info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine z_vect_ins_a + + module subroutine z_vect_ins_v(n,irl,val,x,maxr,info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + 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, 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,maxr,info) + + end subroutine z_vect_ins_v + + + module subroutine z_vect_cnv(x,mold) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + class(psb_z_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_z_get_base_vect_default()) + end if + if (allocated(x%v)) then + if (allocated(x%v%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) + call x%v%free(info) + endif + end if + call move_alloc(tmp,x%v) + + end subroutine z_vect_cnv + + + module subroutine z_vect_sync(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine z_vect_sync + + module subroutine z_vect_set_sync(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine z_vect_set_sync + + module subroutine z_vect_set_host(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine z_vect_set_host + + module subroutine z_vect_set_dev(x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine z_vect_set_dev + + module function z_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_z_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function z_vect_is_sync + + module function z_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_z_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function z_vect_is_host + + module function z_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_z_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function z_vect_is_dev + + + module function z_vect_get_entry(x,index) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: res + res = zzero + if (allocated(x%v)) res = x%v%get_entry(index) + end function z_vect_get_entry + + module subroutine z_vect_set_entry(x,index,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine z_vect_set_entry + + module function z_vect_dot_v(n,x,y) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + + res = zzero + if (allocated(x%v).and.allocated(y%v)) & + & res = x%v%dot(n,y%v) + + end function z_vect_dot_v + + module function z_vect_dot_a(n,x,y) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + + res = zzero + if (allocated(x%v)) & + & res = x%v%dot_a(n,y) + + end function z_vect_dot_a + + module subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call y%v%axpby(m,alpha,x%v,beta,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine z_vect_axpby_v + + module subroutine z_vect_axpby_v2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine z_vect_axpby_v2 + + module subroutine z_vect_axpby_a(m,alpha, x, beta, y, info) + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(y%v)) & + & call y%v%axpby(m,alpha,x,beta,info) + + end subroutine z_vect_axpby_a + + module subroutine z_vect_axpby_a2(m,alpha, x, beta, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine z_vect_axpby_a2 + + module subroutine z_vect_upd_xyz(m,alpha,beta,gamma,delta,x, y, z, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + call z%v%upd_xyz(m,alpha,beta,gamma,delta,x%v,y%v,info) + + end subroutine z_vect_upd_xyz + + module subroutine z_vect_xyzw(m,a,b,c,d,e,f,x, y, z, w, info) + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + class(psb_z_vect_type), intent(inout) :: w + complex(psb_dpk_), intent (in) :: a, b, c, d, e, f + integer(psb_ipk_), intent(out) :: info + + if (allocated(w%v)) & + call w%v%xyzw(m,a,b,c,d,e,f,x%v,y%v,z%v,info) + + end subroutine z_vect_xyzw + + + module subroutine z_vect_mlt_v(x, y, info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%mlt(x%v,info) + + end subroutine z_vect_mlt_v + + module subroutine z_vect_mlt_a(x, y, info) + implicit none + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + + info = 0 + if (allocated(y%v)) & + & call y%v%mlt(x,info) + + end subroutine z_vect_mlt_a + + + module subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info) + implicit none + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: y(:) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%mlt(alpha,x,y,beta,info) + + end subroutine z_vect_mlt_a_2 + + module subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + implicit none + complex(psb_dpk_), intent(in) :: alpha,beta + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.& + & allocated(z%v)) & + & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) + + end subroutine z_vect_mlt_v_2 + + module subroutine z_vect_mlt_av(alpha,x,y,beta,z,info) + implicit none + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v).and.allocated(y%v)) & + & call z%v%mlt(alpha,x,y%v,beta,info) + + end subroutine z_vect_mlt_av + + module subroutine z_vect_mlt_va(alpha,x,y,beta,z,info) + implicit none + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + + if (allocated(z%v).and.allocated(x%v)) & + & call z%v%mlt(alpha,x%v,y,beta,info) + + end subroutine z_vect_mlt_va + + module subroutine z_vect_div_v(x, y, info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine z_vect_div_v + + module subroutine z_vect_div_v2( x, y, z, info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine z_vect_div_v2 + + module subroutine z_vect_div_v_check(x, y, info, flag) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine z_vect_div_v_check + + module subroutine z_vect_div_v2_check(x, y, z, info, flag) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine z_vect_div_v2_check + + module subroutine z_vect_div_a2(x, y, z, info) + implicit none + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine z_vect_div_a2 + + module subroutine z_vect_div_a2_check(x, y, z, info,flag) + implicit none + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine z_vect_div_a2_check + + module subroutine z_vect_inv_v(x, y, info) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine z_vect_inv_v + + module subroutine z_vect_inv_v_check(x, y, info, flag) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine z_vect_inv_v_check + + module subroutine z_vect_inv_a2(x, y, info) + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine z_vect_inv_a2 + + module subroutine z_vect_inv_a2_check(x, y, info,flag) + + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine z_vect_inv_a2_check + + module subroutine z_vect_acmp_a2(x,c,z,info) + implicit none + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine z_vect_acmp_a2 + + module subroutine z_vect_acmp_v2(x,c,z,info) + implicit none + real(psb_dpk_), intent(in) :: c + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine z_vect_acmp_v2 + + module subroutine z_vect_scal(alpha, x) + implicit none + class(psb_z_vect_type), intent(inout) :: x + complex(psb_dpk_), intent (in) :: alpha + + if (allocated(x%v)) call x%v%scal(alpha) + + end subroutine z_vect_scal + + module subroutine z_vect_absval1(x) + class(psb_z_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%absval() + + end subroutine z_vect_absval1 + + module subroutine z_vect_absval2(x,y) + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + + if (allocated(x%v)) then + if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) + call x%v%absval(y%v) + end if + end subroutine z_vect_absval2 + + module function z_vect_nrm2(n,x) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then + res = x%v%nrm2(n) + else + res = dzero + end if + + end function z_vect_nrm2 + + module function z_vect_nrm2_weight(n,x,w,aux) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: w + class(psb_z_vect_type), intent(inout), optional :: aux + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: info + + ! Temp vectors + type(psb_z_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,zone,w%v%v,zzero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -done + return + end if + + if (allocated(x%v)) then + if (.not.present(aux)) then + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = dzero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function z_vect_nrm2_weight + + module function z_vect_nrm2_weight_mask(n,x,w,id,info,aux) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: w + class(psb_z_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_), intent(out) :: info + class(psb_z_vect_type), intent(inout), optional :: aux + + ! Temp vectors + type(psb_z_vect_type) :: wtemp + + info = 0 + if( allocated(w%v) ) then + if (.not.present(aux)) then + allocate(wtemp%v, mold=w%v) + call wtemp%v%bld(w%get_vect()) + else + call psb_geaxpby(n,zone,w%v%v,zzero,aux%v%v,info) + end if + else + info = -1 + end if + if (info /= 0 ) then + res = -done + return + end if + + + if (allocated(x%v).and.allocated(id%v)) then + if (.not.present(aux)) then + where( abs(id%v%v) <= dzero) wtemp%v%v = dzero + call wtemp%set_host() + call wtemp%v%mlt(x%v,info) + res = wtemp%v%nrm2(n) + else + where( abs(id%v%v) <= dzero) aux%v%v = dzero + call aux%set_host() + call aux%v%mlt(x%v,info) + res = aux%v%nrm2(n) + end if + else + res = dzero + end if + + if (.not.present(aux)) then + call wtemp%free(info) + end if + + end function z_vect_nrm2_weight_mask + + module function z_vect_amax(n,x) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then + res = x%v%amax(n) + else + res = dzero + end if + + end function z_vect_amax + + + module function z_vect_asum(n,x) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then + res = x%v%asum(n) + else + res = dzero + end if + + end function z_vect_asum + + + + module subroutine z_vect_addconst_a2(x,b,z,info) + implicit none + real(psb_dpk_), intent(in) :: b + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine z_vect_addconst_a2 + + module subroutine z_vect_addconst_v2(x,b,z,info) + + real(psb_dpk_), intent(in) :: b + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine z_vect_addconst_v2 + +end submodule psb_z_vect_impl + + +submodule (psb_z_multivect_mod) psb_z_multivect_impl + use psi_serial_mod + use psb_realloc_mod + +contains + + module function z_mvect_get_dupl(x) result(res) + implicit none + class(psb_z_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function z_mvect_get_dupl + + module subroutine z_mvect_set_dupl(x,val) + implicit none + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%dupl = val + else + x%dupl = psb_dupl_def_ + end if + end subroutine z_mvect_set_dupl + + + module function z_mvect_is_remote_build(x) result(res) + implicit none + class(psb_z_multivect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function z_mvect_is_remote_build + + module subroutine z_mvect_set_remote_build(x,val) + implicit none + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine z_mvect_set_remote_build + + + module subroutine psb_z_set_multivect_default(v) + implicit none + class(psb_z_base_multivect_type), intent(in) :: v + + if (allocated(psb_z_base_multivect_default)) then + deallocate(psb_z_base_multivect_default) + end if + allocate(psb_z_base_multivect_default, mold=v) + + end subroutine psb_z_set_multivect_default + + module function psb_z_get_multivect_default(v) result(res) + implicit none + class(psb_z_multivect_type), intent(in) :: v + class(psb_z_base_multivect_type), pointer :: res + + res => psb_z_get_base_multivect_default() + + end function psb_z_get_multivect_default + + + module function psb_z_get_base_multivect_default() result(res) + implicit none + class(psb_z_base_multivect_type), pointer :: res + + if (.not.allocated(psb_z_base_multivect_default)) then + allocate(psb_z_base_multivect_type :: psb_z_base_multivect_default) + end if + + res => psb_z_base_multivect_default + + end function psb_z_get_base_multivect_default + + + module subroutine z_mvect_clone(x,y,info) + implicit none + class(psb_z_multivect_type), intent(inout) :: x + class(psb_z_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld_x(x%get_vect(),mold=x%v) + end if + end subroutine z_mvect_clone + + module subroutine z_mvect_bld_x(x,invect,mold) + complex(psb_dpk_), intent(in) :: invect(:,:) + class(psb_z_multivect_type), intent(out) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_z_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine z_mvect_bld_x + + + module subroutine z_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(out) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) + + end subroutine z_mvect_bld_n + + module function z_mvect_get_vect(x) result(res) + class(psb_z_multivect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function z_mvect_get_vect + + module subroutine z_mvect_set_scal(x,val) + class(psb_z_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine z_mvect_set_scal + + module subroutine z_mvect_set_vect(x,val) + class(psb_z_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine z_mvect_set_vect + + module function z_mvect_get_nrows(x) result(res) + implicit none + class(psb_z_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function z_mvect_get_nrows + + module function z_mvect_get_ncols(x) result(res) + implicit none + class(psb_z_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function z_mvect_get_ncols + + module function z_mvect_sizeof(x) result(res) + implicit none + class(psb_z_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function z_mvect_sizeof + + module function z_mvect_get_fmt(x) result(res) + implicit none + class(psb_z_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function z_mvect_get_fmt + + module subroutine z_mvect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(out) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_z_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine z_mvect_all + + module subroutine z_mvect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine z_mvect_reall + + module subroutine z_mvect_zero(x) + use psi_serial_mod + implicit none + class(psb_z_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine z_mvect_zero + + module subroutine z_mvect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine z_mvect_asb + + module subroutine z_mvect_sync(x) + implicit none + class(psb_z_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine z_mvect_sync + + module subroutine z_mvect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine z_mvect_gthab + + module subroutine z_mvect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine z_mvect_gthzv + + module subroutine z_mvect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: y(:) + class(psb_z_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine z_mvect_gthzv_x + + module subroutine z_mvect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine z_mvect_sctb + + module subroutine z_mvect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta, x(:) + class(psb_z_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine z_mvect_sctb_x + + module subroutine z_mvect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine z_mvect_free + + module subroutine z_mvect_ins(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + 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,maxr,info) + + end subroutine z_mvect_ins + + + module subroutine z_mvect_cnv(x,mold) + class(psb_z_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(in), optional :: mold + class(psb_z_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_z_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine z_mvect_cnv + + +!!$ module function z_mvect_dot_v(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_z_multivect_type), intent(inout) :: x, y +!!$ integer(psb_ipk_), intent(in) :: n +!!$ complex(psb_dpk_) :: res +!!$ +!!$ res = zzero +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & res = x%v%dot(n,y%v) +!!$ +!!$ end function z_mvect_dot_v +!!$ +!!$ module function z_mvect_dot_a(n,x,y) result(res) +!!$ implicit none +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ complex(psb_dpk_), intent(in) :: y(:) +!!$ integer(psb_ipk_), intent(in) :: n +!!$ complex(psb_dpk_) :: res +!!$ +!!$ res = zzero +!!$ if (allocated(x%v)) & +!!$ & res = x%v%dot(n,y) +!!$ +!!$ end function z_mvect_dot_a +!!$ +!!$ module subroutine z_mvect_axpby_v(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ class(psb_z_multivect_type), intent(inout) :: y +!!$ complex(psb_dpk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ call y%v%axpby(m,alpha,x%v,beta,info) +!!$ else +!!$ info = psb_err_invalid_mvect_state_ +!!$ end if +!!$ +!!$ end subroutine z_mvect_axpby_v +!!$ +!!$ module subroutine z_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ integer(psb_ipk_), intent(in) :: m +!!$ complex(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_z_multivect_type), intent(inout) :: y +!!$ complex(psb_dpk_), intent (in) :: alpha, beta +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ if (allocated(y%v)) & +!!$ & call y%v%axpby(m,alpha,x,beta,info) +!!$ +!!$ end subroutine z_mvect_axpby_a +!!$ +!!$ +!!$ module subroutine z_mvect_mlt_v(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ class(psb_z_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v)) & +!!$ & call y%v%mlt(x%v,info) +!!$ +!!$ end subroutine z_mvect_mlt_v +!!$ +!!$ module subroutine z_mvect_mlt_a(x, y, info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_z_multivect_type), intent(inout) :: y +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ +!!$ info = 0 +!!$ if (allocated(y%v)) & +!!$ & call y%v%mlt(x,info) +!!$ +!!$ end subroutine z_mvect_mlt_a +!!$ +!!$ +!!$ module subroutine z_mvect_mlt_a_2(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_dpk_), intent(in) :: alpha,beta +!!$ complex(psb_dpk_), intent(in) :: y(:) +!!$ complex(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_z_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x,y,beta,info) +!!$ +!!$ end subroutine z_mvect_mlt_a_2 +!!$ +!!$ module subroutine z_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_dpk_), intent(in) :: alpha,beta +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ class(psb_z_multivect_type), intent(inout) :: y +!!$ class(psb_z_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ character(len=1), intent(in), optional :: conjgx, conjgy +!!$ +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(x%v).and.allocated(y%v).and.& +!!$ & allocated(z%v)) & +!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy) +!!$ +!!$ end subroutine z_mvect_mlt_v_2 +!!$ +!!$ module subroutine z_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_dpk_), intent(in) :: alpha,beta +!!$ complex(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_z_multivect_type), intent(inout) :: y +!!$ class(psb_z_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ if (allocated(z%v).and.allocated(y%v)) & +!!$ & call z%v%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine z_mvect_mlt_av +!!$ +!!$ module subroutine z_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ use psi_serial_mod +!!$ implicit none +!!$ complex(psb_dpk_), intent(in) :: alpha,beta +!!$ complex(psb_dpk_), intent(in) :: y(:) +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ class(psb_z_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ if (allocated(z%v).and.allocated(x%v)) & +!!$ & call z%v%mlt(alpha,x%v,y,beta,info) +!!$ +!!$ end subroutine z_mvect_mlt_va +!!$ +!!$ module subroutine z_mvect_scal(alpha, x) +!!$ use psi_serial_mod +!!$ implicit none +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ complex(psb_dpk_), intent (in) :: alpha +!!$ +!!$ if (allocated(x%v)) call x%v%scal(alpha) +!!$ +!!$ end subroutine z_mvect_scal +!!$ +!!$ +!!$ module function z_mvect_nrm2(n,x) result(res) +!!$ implicit none +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%nrm2(n) +!!$ else +!!$ res = dzero +!!$ end if +!!$ +!!$ end function z_mvect_nrm2 +!!$ +!!$ module function z_mvect_amax(n,x) result(res) +!!$ implicit none +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%amax(n) +!!$ else +!!$ res = dzero +!!$ end if +!!$ +!!$ end function z_mvect_amax +!!$ +!!$ module function z_mvect_asum(n,x) result(res) +!!$ implicit none +!!$ class(psb_z_multivect_type), intent(inout) :: x +!!$ integer(psb_ipk_), intent(in) :: n +!!$ real(psb_dpk_) :: res +!!$ +!!$ if (allocated(x%v)) then +!!$ res = x%v%asum(n) +!!$ else +!!$ res = dzero +!!$ end if +!!$ +!!$ end function z_mvect_asum + +end submodule psb_z_multivect_impl + diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index 6c9460a1..4cea1d23 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -266,6 +266,7 @@ contains end if ixb = psb_c_get_index_base() + write(0,*) 'C_get_entry: ',index,(index+(1-ixb)) res = xp%get_entry((index+(1-ixb))) end function psb_c_dvect_get_entry