diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index 6ca78a379..fb4dcbf79 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -246,45 +246,12 @@ module psb_c_base_vect_mod end type psb_c_base_vect_type - public :: psb_c_base_vect + public :: psb_c_base_vect, psb_c_base_vect_type private :: constructor, size_const interface psb_c_base_vect module procedure constructor, size_const end interface psb_c_base_vect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - complex(psb_spk_) :: x(:) - type(psb_c_base_vect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(n) result(this) - integer(psb_ipk_), intent(in) :: n - type(psb_c_base_vect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(n,info) - - end function size_const - ! ! Build from a sample ! @@ -294,36 +261,13 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine c_base_bld_x(x,this,scratch) - use psb_realloc_mod - implicit none - complex(psb_spk_), intent(in) :: this(:) - class(psb_c_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - integer(psb_ipk_) :: i - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(size(this),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') - return - end if -#if defined (PSB_OPENMP) - !$omp parallel do private(i) - do i = 1, size(this) - x%v(i) = this(i) - end do -#else - x%v(:) = this(:) -#endif - end subroutine c_base_bld_x + interface + module subroutine c_base_bld_x(x,this,scratch) + complex(psb_spk_), intent(in) :: this(:) + class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine c_base_bld_x + end interface ! ! Create with size, but no initialization @@ -334,50 +278,26 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_bld_mn(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_c_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine c_base_bld_mn - + interface + module subroutine c_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine c_base_bld_mn + end interface + !> Function bld_en: !! \memberof psb_c_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_bld_en(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_c_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine c_base_bld_en + interface + module subroutine c_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine c_base_bld_en + end interface !> Function base_all: !! \memberof psb_c_base_vect_type @@ -386,21 +306,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine c_base_all(n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_c_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine c_base_all + interface + module subroutine c_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_c_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_all + end interface !> Function base_mold: !! \memberof psb_c_base_vect_type @@ -408,42 +320,21 @@ contains !! \param y returned variable !! \param info return code !! - subroutine c_base_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(in) :: x - class(psb_c_base_vect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_c_base_vect_type :: y, stat=info) - - end subroutine c_base_mold - - subroutine c_base_reinit(x, info,clear) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - logical :: clear_ - - info = 0 - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - if (clear_) x%v(:) = czero - call x%set_host() - call x%set_upd() - end if - - end subroutine c_base_reinit + interface + module subroutine c_base_mold(x, y, info) + class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mold + end interface + + interface + module subroutine c_base_reinit(x, info,clear) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine c_base_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -472,152 +363,27 @@ contains !! \param info return code !! ! - subroutine c_base_ins_a(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine c_base_ins_a - - subroutine c_base_ins_v(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - class(psb_i_base_vect_type), intent(inout) :: irl - class(psb_c_base_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: isz - - info = 0 - if (psb_errstatus_fatal()) return - - if (irl%is_dev()) call irl%sync() - if (val%is_dev()) call val%sync() - if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,maxr,info) - - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine c_base_ins_v + interface + module subroutine c_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_ins_a + end interface + + + interface + module subroutine c_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_c_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_ins_v + end interface + ! @@ -626,18 +392,12 @@ contains !! \brief Zero out contents !! ! - subroutine c_base_zero(x) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x + interface + module subroutine c_base_zero(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_zero + end interface - if (allocated(x%v)) then - !$omp workshare - x%v(:)=czero - !$omp end workshare - end if - call x%set_host() - end subroutine c_base_zero ! @@ -654,74 +414,15 @@ contains !! ! - subroutine c_base_asb_m(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - complex(psb_spk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(n,vv,info) - vv(:) = czero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (vv(x%iv(i)).ne. czero) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine c_base_asb_m + interface + module subroutine c_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine c_base_asb_m + end interface + ! ! Assembly. @@ -737,74 +438,15 @@ contains !! ! - subroutine c_base_asb_e(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - complex(psb_spk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') - if (x%is_bld()) then - call psb_realloc(n,vv,info) - vv(:) = czero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne. czero) then - call psb_errpush(psb_err_duplicate_coo,'vect_asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine c_base_asb_e + interface + module subroutine c_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine c_base_asb_e + end interface + ! !> Function base_free: @@ -814,22 +456,13 @@ contains !! \param info return code !! ! - subroutine c_base_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine c_base_free(x, info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_free + end interface - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - call x%set_null() - end subroutine c_base_free ! !> Function base_free_buffer: @@ -839,15 +472,13 @@ contains !! \param info return code !! ! - subroutine c_base_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine c_base_free_buffer(x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_free_buffer + end interface - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine c_base_free_buffer ! !> Function base_maybe_free_buffer: @@ -860,17 +491,13 @@ contains !! \param info return code !! ! - subroutine c_base_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) + interface + module subroutine c_base_maybe_free_buffer(x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_maybe_free_buffer + end interface - end subroutine c_base_maybe_free_buffer ! !> Function base_free_comid: @@ -880,113 +507,107 @@ contains !! \param info return code !! ! - subroutine c_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine c_base_free_comid - - function c_base_get_ncfs(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function c_base_get_ncfs - - function c_base_get_dupl(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function c_base_get_dupl - - function c_base_get_state(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function c_base_get_state - - function c_base_is_null(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function c_base_is_null - - function c_base_is_bld(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function c_base_is_bld - - function c_base_is_upd(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function c_base_is_upd - - function c_base_is_asb(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function c_base_is_asb - - subroutine c_base_set_ncfs(n,x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine c_base_set_ncfs - - subroutine c_base_set_dupl(n,x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine c_base_set_dupl - - subroutine c_base_set_state(n,x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine c_base_set_state - - subroutine c_base_set_null(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine c_base_set_null - - subroutine c_base_set_bld(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine c_base_set_bld - - subroutine c_base_set_upd(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine c_base_set_upd - - subroutine c_base_set_asb(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine c_base_set_asb + interface + module subroutine c_base_free_comid(x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_free_comid + end interface + + + interface + module function c_base_get_ncfs(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_get_ncfs + end interface + + interface + module function c_base_get_dupl(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_get_dupl + end interface + + interface + module function c_base_get_state(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_get_state + end interface + + interface + module function c_base_is_null(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + end function c_base_is_null + end interface + + interface + module function c_base_is_bld(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + end function c_base_is_bld + end interface + + interface + module function c_base_is_upd(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + end function c_base_is_upd + end interface + + interface + module function c_base_is_asb(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + end function c_base_is_asb + end interface + + interface + module subroutine c_base_set_ncfs(n,x) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine c_base_set_ncfs + end interface + + interface + module subroutine c_base_set_dupl(n,x) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine c_base_set_dupl + end interface + + interface + module subroutine c_base_set_state(n,x) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine c_base_set_state + end interface + + interface + module subroutine c_base_set_null(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_set_null + end interface + + interface + module subroutine c_base_set_bld(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_set_bld + end interface + + interface + module subroutine c_base_set_upd(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_set_upd + end interface + + interface + module subroutine c_base_set_asb(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -998,11 +619,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine c_base_sync(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - end subroutine c_base_sync + interface + module subroutine c_base_sync(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_sync + end interface ! !> Function base_set_host: @@ -1010,11 +631,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine c_base_set_host(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - end subroutine c_base_set_host + interface + module subroutine c_base_set_host(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_set_host + end interface ! !> Function base_set_dev: @@ -1022,11 +643,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine c_base_set_dev(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - end subroutine c_base_set_dev + interface + module subroutine c_base_set_dev(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_set_dev + end interface ! !> Function base_set_sync: @@ -1034,11 +655,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine c_base_set_sync(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - end subroutine c_base_set_sync + interface + module subroutine c_base_set_sync(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_set_sync + end interface ! !> Function base_is_dev: @@ -1046,13 +667,12 @@ contains !! \brief Is vector on external device . !! ! - function c_base_is_dev(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - logical :: res - - res = .false. - end function c_base_is_dev + interface + module function c_base_is_dev(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + end function c_base_is_dev + end interface ! !> Function base_is_host @@ -1060,13 +680,12 @@ contains !! \brief Is vector on standard memory . !! ! - function c_base_is_host(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function c_base_is_host + interface + module function c_base_is_host(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + end function c_base_is_host + end interface ! !> Function base_is_sync @@ -1074,32 +693,24 @@ contains !! \brief Is vector on sync . !! ! - function c_base_is_sync(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function c_base_is_sync + interface + module function c_base_is_sync(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + end function c_base_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine c_base_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(in) :: x - class(psb_c_base_vect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine c_base_cpy + interface + module subroutine c_base_cpy(x, y) + class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(out) :: y + end subroutine c_base_cpy + end interface ! ! Size info. @@ -1110,15 +721,12 @@ contains !! \brief Number of entries !! ! - function c_base_get_nrows(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v) - - end function c_base_get_nrows + interface + module function c_base_get_nrows(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_get_nrows + end interface ! !> Function base_get_sizeof @@ -1126,15 +734,12 @@ contains !! \brief Size in bytes !! ! - function c_base_sizeof(x) result(res) - implicit none - class(psb_c_base_vect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() - - end function c_base_sizeof + interface + module function c_base_sizeof(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function c_base_sizeof + end interface ! !> Function base_get_fmt @@ -1142,12 +747,11 @@ contains !! \brief Format !! ! - function c_base_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function c_base_get_fmt - + interface + module function c_base_get_fmt() result(res) + character(len=5) :: res + end function c_base_get_fmt + end interface ! ! @@ -1157,34 +761,14 @@ contains !! \brief Extract a copy of the contents !! ! - function c_base_get_vect(x,n) result(res) - class(psb_c_base_vect_type), intent(inout) :: x - complex(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - ! Local variables - integer(psb_ipk_) :: isz, i - - if (.not.allocated(x%v)) return - if (.not.x%is_host()) call x%sync() - isz = x%get_nrows() - if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') - return - end if - if (.false.) then - res(1:isz) = x%v(1:isz) - else - !$omp parallel do private(i) - do i=1, isz - res(i) = x%v(i) - end do - end if - - end function c_base_get_vect - + interface + module function c_base_get_vect(x,n) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function c_base_get_vect + end interface + ! ! Reset all values ! @@ -1194,32 +778,13 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine c_base_set_scal(x,val,first,last) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i - - first_=1 - last_=size(x%v) - if (present(first)) first_ = max(1,first) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val - end do -#else - x%v(first_:last_) = val -#endif - call x%set_host() - - end subroutine c_base_set_scal - + interface + module subroutine c_base_set_scal(x,val,first,last) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine c_base_set_scal + end interface ! !> Function base_set_vect @@ -1227,45 +792,20 @@ contains !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine c_base_set_vect(x,val,first,last) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i, info - - if (.not.allocated(x%v)) then - call psb_realloc(size(val),x%v,info) - end if - - first_ = 1 - if (present(first)) first_ = max(1,first) - last_ = min(psb_size(x%v),first_+size(val)-1) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() - -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val(i-first_+1) - end do -#else - x%v(first_:last_) = val(1:last_-first_+1) -#endif - call x%set_host() - - end subroutine c_base_set_vect - - subroutine c_base_check_addr(x) - class(psb_c_base_vect_type), intent(inout) :: x - - write(0,*) 'Check addr: base version, do nothing' - - end subroutine c_base_check_addr - - + interface + module subroutine c_base_set_vect(x,val,first,last) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine c_base_set_vect + end interface + + interface + module subroutine c_base_check_addr(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_check_addr + end interface + ! ! Get entry. ! @@ -1275,33 +815,22 @@ contains !! \brief Get one entry from the vector !! ! - function c_base_get_entry(x, index) result(res) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_spk_) :: res - - res = czero - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - res = x%v(index) - end if - - end function c_base_get_entry - - subroutine c_base_set_entry(x, index, val) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_spk_) :: val - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v(index) =val - call x%set_host() - end if - end subroutine c_base_set_entry - + interface + module function c_base_get_entry(x, index) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: res + end function c_base_get_entry + end interface + + interface + module subroutine c_base_set_entry(x, index, val) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + end subroutine c_base_set_entry + end interface + ! ! Overwrite with absolute value ! @@ -1310,40 +839,19 @@ contains !! \memberof psb_c_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine c_base_absval1(x) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: i - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1, size(x%v) - x%v(i) = abs(x%v(i)) - end do -#else - x%v = abs(x%v) -#endif - call x%set_host() - end if - - end subroutine c_base_absval1 - - subroutine c_base_absval2(x,y) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_) :: info - if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then - call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) - call y%absval() - end if - - end subroutine c_base_absval2 - + interface + module subroutine c_base_absval1(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_absval1 + end interface + + interface + module subroutine c_base_absval2(x,y) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + end subroutine c_base_absval2 + end interface + ! ! Dot products ! @@ -1354,29 +862,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_vect) to be multiplied by !! - function c_base_dot_v(n,x,y) result(res) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - complex(psb_spk_) :: res - complex(psb_spk_), external :: cdotc - - res = czero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_c_base_vect. - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_c_base_vect_type) - res = cdotc(n,x%v,1,y%v,1) - class default - res = y%dot(n,x%v) - end select - - end function c_base_dot_v + interface + module function c_base_dot_v(n,x,y) result(res) + class(psb_c_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + end function + end interface ! ! Base workhorse is good old BLAS1 @@ -1388,17 +880,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function c_base_dot_a(n,x,y) result(res) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - complex(psb_spk_) :: res - complex(psb_spk_), external :: cdotc - - res = cdotc(n,y,1,x%v,1) - - end function c_base_dot_a + interface + module function c_base_dot_a(n,x,y) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + end function c_base_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1414,20 +903,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine c_base_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call y%axpby(m,alpha,x%v,beta,info) - - end subroutine c_base_axpby_v + interface + module subroutine c_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_axpby_v + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1445,21 +929,16 @@ contains !! \param z The class(base_vect) to be returned !! \param info return code !! - subroutine c_base_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - class(psb_c_base_vect_type), intent(inout) :: z - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call z%axpby(m,alpha,x%v,beta,y%v,info) - - end subroutine c_base_axpby_v2 + interface + module subroutine c_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_axpby_v2 + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1474,20 +953,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine c_base_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_base_vect_type), intent(inout) :: y - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (y%is_dev()) call y%sync() - call psb_geaxpby(m,alpha,x,beta,y%v,info) - call y%set_host() - - end subroutine c_base_axpby_a + interface + module subroutine c_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_axpby_a + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1503,21 +977,16 @@ contains !! \param y(:) The array to be added !! \param info return code !! - subroutine c_base_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_base_vect_type), intent(inout) :: z - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (z%is_dev()) call z%sync() - call psb_geaxpby(m,alpha,x,beta,y,z%v,info) - call z%set_host() - - end subroutine c_base_axpby_a2 + interface + module subroutine c_base_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_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_axpby_a2 + end interface ! ! UPD_XYZ is invoked via Z, hence the structure below. @@ -1536,48 +1005,29 @@ contains !! \param z The class(base_vect) to be added !! \param info return code !! - subroutine c_base_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_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - class(psb_c_base_vect_type), intent(inout) :: z - complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(alpha/=czero)) call x%sync() - if (y%is_dev().and.(beta/=czero)) call y%sync() - if (z%is_dev().and.(delta/=czero)) call z%sync() - call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) - call y%set_host() - call z%set_host() - - end subroutine c_base_upd_xyz - - subroutine c_base_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_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - class(psb_c_base_vect_type), intent(inout) :: z - class(psb_c_base_vect_type), intent(inout) :: w - complex(psb_spk_), intent (in) :: a,b,c,d,e,f - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(a/=czero)) call x%sync() - if (y%is_dev().and.(b/=czero)) call y%sync() - if (z%is_dev().and.(d/=czero)) call z%sync() - if (w%is_dev().and.(f/=czero)) call w%sync() - call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) - call y%set_host() - call z%set_host() - call w%set_host() - - end subroutine c_base_xyzw - - + interface + module subroutine c_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_upd_xyz + end interface + + interface + module subroutine c_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + class(psb_c_base_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_base_xyzw + end interface + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -1593,20 +1043,14 @@ contains !! \param x The class(base_vect) to be multiplied by !! \param info return code !! - subroutine c_base_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine c_base_mlt_v - + interface + module subroutine c_base_mlt_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlt_v + end interface + ! !> Function base_mlt_a !! \memberof psb_c_base_vect_type @@ -1614,25 +1058,13 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine c_base_mlt_a(x, y, info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: x(:) - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)*x(i) - end do - call y%set_host() - - end subroutine c_base_mlt_a - + interface + module subroutine c_base_mlt_a(x, y, info) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlt_a + end interface ! !> Function base_mlt_a_2 @@ -1645,87 +1077,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine c_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(z%v), size(x), size(y)) - if (alpha == czero) then - if (beta == cone) then - return - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - end do - end if - else - if (alpha == cone) then - if (beta == czero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = y(i)*x(i) - end do - else if (beta == cone) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) + y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) + y(i)*x(i) - end do - end if - else if (alpha == -cone) then - if (beta == czero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = -y(i)*x(i) - end do - else if (beta == cone) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) - y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - y(i)*x(i) - end do - end if - else - if (beta == czero) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = alpha*y(i)*x(i) - end do - else if (beta == cone) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = z%v(i) + alpha*y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(alpha, beta) - do i=1, n - z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) - end do - end if - end if - end if - call z%set_host() - - end subroutine c_base_mlt_a_2 - + interface + module subroutine c_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlt_a_2 + end interface + ! !> Function base_mlt_v_2 !! \memberof psb_c_base_vect_type @@ -1737,68 +1098,37 @@ contains !! \param y The class(base_vect) to be multiplied by !! \param info return code !! - subroutine c_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - complex(psb_spk_), intent(in) :: alpha,beta - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (y%is_dev()) call y%sync() - if (x%is_dev()) call x%sync() - if (.not.psb_c_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - end if - end subroutine c_base_mlt_v_2 - - subroutine c_base_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_base_vect_type), intent(inout) :: y - class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call z%mlt(alpha,x,y%v,beta,info) - - end subroutine c_base_mlt_av - - subroutine c_base_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_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call z%mlt(alpha,y,x,beta,info) - - end subroutine c_base_mlt_va + interface + module subroutine c_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_spk_), intent(in) :: alpha,beta + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine c_base_mlt_v_2 + end interface + + interface + module subroutine c_base_mlt_av(alpha,x,y,beta,z,info) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlt_av + end interface + + interface + module subroutine c_base_mlt_va(alpha,x,y,beta,z,info) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlt_va + end interface + ! !> Function base_div_v !! \memberof psb_c_base_vect_type @@ -1806,38 +1136,22 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine c_base_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%div(x%v,info) - - end subroutine c_base_div_v - - subroutine c_base_div_a(x, y, info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: x(:) - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)/x(i) - end do - call y%set_host() - - end subroutine c_base_div_a + interface + module subroutine c_base_div_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_div_v + end interface + + interface + module subroutine c_base_div_a(x, y, info) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_div_a + end interface + ! !> Function base_div_v2 !! \memberof psb_c_base_vect_type @@ -1845,21 +1159,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine c_base_div_v2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call z%div(x%v,y%v,info) - call z%set_host() - end subroutine c_base_div_v2 + interface + module subroutine c_base_div_v2(x, y, z, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_div_v2 + end interface + ! !> Function base_div_v_check !! \memberof psb_c_base_vect_type @@ -1867,21 +1175,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine c_base_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call x%div(x%v,y%v,info,flag) - - end subroutine c_base_div_v_check + interface + module subroutine c_base_div_v_check(x, y, info, flag) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_base_div_v_check + end interface + ! !> Function base_div_v2_check !! \memberof psb_c_base_vect_type @@ -1889,21 +1191,16 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine c_base_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info,flag) - - end subroutine c_base_div_v2_check + interface + module subroutine c_base_div_v2_check(x, y, z, info, flag) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_base_div_v2_check + end interface + ! !> Function base_div_a2 !! \memberof psb_c_base_vect_type @@ -1911,25 +1208,15 @@ contains !! \param y(:) The array to be divided by !! \param info return code !! - subroutine c_base_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: z - complex(psb_spk_), intent(in) :: x(:) - complex(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - !$omp parallel do private(i) - do i=1, n - z%v(i) = x(i)/y(i) - end do - - end subroutine c_base_div_a2 + interface + module subroutine c_base_div_a2(x, y, z, info) + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_div_a2 + end interface + ! !> Function base_div_a2_check !! \memberof psb_c_base_vect_type @@ -1938,35 +1225,16 @@ contains !! \param y(:) The array to be dived by !! \param info return code !! - subroutine c_base_div_a2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: z - complex(psb_spk_), intent(in) :: x(:) - complex(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call c_base_div_a2(x, y, z, info) - else - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - ! $omp parallel do private(i) - do i=1, n - if (y(i) /= 0) then - z%v(i) = x(i)/y(i) - else - info = 1 - exit - end if - end do - end if - - end subroutine c_base_div_a2_check + interface + module subroutine c_base_div_a2_check(x, y, z, info, flag) + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_base_div_a2_check + end interface + ! !> Function base_inv_v !! \memberof psb_c_base_vect_type @@ -1974,20 +1242,14 @@ contains !! \param x The vector to be inverted !! \param y The vector containing the inverted vector !! \param info return code - subroutine c_base_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info) - - - end subroutine c_base_inv_v + interface + module subroutine c_base_inv_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_inv_v + end interface + ! !> Function base_inv_v_check !! \memberof psb_c_base_vect_type @@ -1996,20 +1258,16 @@ contains !! \param y The vector containing the inverted vector !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v - subroutine c_base_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info,flag) - - end subroutine c_base_inv_v_check + interface + module subroutine c_base_inv_v_check(x, y, info, flag) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + end subroutine c_base_inv_v_check + end interface + ! !> Function base_inv_a2 !! \memberof psb_c_base_vect_type @@ -2018,24 +1276,14 @@ contains !! \param y The vector containing the inverted vector !! \param info return code ! - subroutine c_base_inv_a2(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: y - complex(psb_spk_), intent(in) :: x(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - y%v(i) = 1_psb_spk_/x(i) - end do - - end subroutine c_base_inv_a2 + interface + module subroutine c_base_inv_a2(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_inv_a2 + end interface + ! !> Function base_inv_a2_check !! \memberof psb_c_base_vect_type @@ -2045,35 +1293,14 @@ contains !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v ! - subroutine c_base_inv_a2_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: y - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call c_base_inv_a2(x, y, info) - else - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - if (x(i) /= 0) then - y%v(i) = 1_psb_spk_/x(i) - else - info = 1 - y%v(i) = 0_psb_spk_ - end if - end do - end if - - - end subroutine c_base_inv_a2_check + interface + module subroutine c_base_inv_a2_check(x, y, info, flag) + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine c_base_inv_a2_check + end interface ! !> Function base_inv_a2_check @@ -2084,29 +1311,15 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine c_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() - - n = size(x) - !$omp parallel do private(i) - do i = 1, n, 1 - if ( abs(x(i)).ge.c ) then - z%v(i) = 1_psb_spk_ - else - z%v(i) = 0_psb_spk_ - end if - end do - info = 0 - - end subroutine c_base_acmp_a2 + interface + module subroutine c_base_acmp_a2(x,c,z,info) + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_acmp_a2 + end interface + ! !> Function base_cmp_v2 !! \memberof psb_c_base_vect_type @@ -2116,18 +1329,14 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine c_base_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: c - class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%acmp(x%v,c,info) - end subroutine c_base_acmp_v2 + interface + module subroutine c_base_acmp_v2(x,c,z,info) + class(psb_c_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_acmp_v2 + end interface ! ! Simple scaling @@ -2137,25 +1346,12 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine c_base_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - complex(psb_spk_), intent (in) :: alpha - integer(psb_ipk_) :: i - - if (allocated(x%v)) then -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1,size(x%v) - x%v(i) = alpha*x%v(i) - end do -#else - x%v = alpha*x%v -#endif - end if - call x%set_host() - end subroutine c_base_scal + interface + module subroutine c_base_scal(alpha, x) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent (in) :: alpha + end subroutine c_base_scal + end interface ! ! Norms 1, 2 and infinity @@ -2164,67 +1360,39 @@ contains !! \memberof psb_c_base_vect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function c_base_nrm2(n,x) result(res) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - real(psb_spk_), external :: scnrm2 - - if (x%is_dev()) call x%sync() - res = scnrm2(n,x%v,1) - - end function c_base_nrm2 + interface + module function c_base_nrm2(n,x) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function c_base_nrm2 + end interface ! !> Function base_amax !! \memberof psb_c_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function c_base_amax(n,x) result(res) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res = szero - !$omp parallel do private(i) reduction(max: res) - do i=1, n - res = max(res,abs(x%v(i))) - end do -#else - res = maxval(abs(x%v(1:n))) -#endif - end function c_base_amax - + interface + module function c_base_amax(n,x) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function c_base_amax + end interface ! !> Function base_asum !! \memberof psb_c_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function c_base_asum(n,x) result(res) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res=szero - !$omp parallel do private(i) reduction(+: res) - do i= 1, size(x%v) - res = res + abs(x%v(i)) - end do -#else - res = sum(abs(x%v(1:n))) -#endif - end function c_base_asum - + interface + module function c_base_asum(n,x) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function c_base_asum + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -2238,18 +1406,15 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine c_base_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: alpha, beta, y(:) - class(psb_c_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,alpha,x%v,beta,y) - - end subroutine c_base_gthab + interface + module subroutine c_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_base_vect_type) :: x + end subroutine c_base_gthab + end interface + ! ! shortcut alpha=1 beta=0 ! @@ -2259,77 +1424,60 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine c_base_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - complex(psb_spk_) :: y(:) - class(psb_c_base_vect_type) :: x - - if (idx%is_dev()) call idx%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine c_base_gthzv_x - + interface + module subroutine c_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: y(:) + class(psb_c_base_vect_type) :: x + end subroutine c_base_gthzv_x + end interface + ! ! New comm internals impl. ! - subroutine c_base_gthzbuf(i,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - class(psb_c_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),x%combuf(i:)) - - end subroutine c_base_gthzbuf + interface + module subroutine c_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_c_base_vect_type) :: x + end subroutine c_base_gthzbuf + end interface + ! !> Function base_device_wait: !! \memberof psb_c_base_vect_type !! \brief device_wait: base version is a no-op. !! ! - subroutine c_base_device_wait() - implicit none - - end subroutine c_base_device_wait - - function c_base_use_buffer() result(res) - logical :: res - - res = .true. - end function c_base_use_buffer - - subroutine c_base_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%combuf,info) - end subroutine c_base_new_buffer - - subroutine c_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine c_base_new_comid + interface + module subroutine c_base_device_wait() + end subroutine c_base_device_wait + end interface + interface + module function c_base_use_buffer() result(res) + logical :: res + end function c_base_use_buffer + end interface + + interface + module subroutine c_base_new_buffer(n,x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_new_buffer + end interface + + interface + module subroutine c_base_new_comid(n,x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_new_comid + end interface ! ! shortcut alpha=1 beta=0 @@ -2340,18 +1488,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine c_base_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: y(:) - class(psb_c_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,x%v,y) - - end subroutine c_base_gthzv + interface + module subroutine c_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_base_vect_type) :: x + end subroutine c_base_gthzv + end interface ! ! Scatter: @@ -2366,57 +1510,35 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine c_base_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: beta, x(:) - class(psb_c_base_vect_type) :: y - - if (y%is_dev()) call y%sync() - call psi_sct(n,idx,x,beta,y%v) - call y%set_host() - - end subroutine c_base_sctb - - subroutine c_base_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_spk_) :: beta, x(:) - class(psb_c_base_vect_type) :: y - - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),x,beta) - call y%set_host() - - end subroutine c_base_sctb_x - - subroutine c_base_sctb_buf(i,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_spk_) :: beta - class(psb_c_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),y%combuf(i:),beta) - call y%set_host() - - end subroutine c_base_sctb_buf - - + interface + module subroutine c_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_base_vect_type) :: y + end subroutine c_base_sctb + end interface + + interface + module subroutine c_base_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_base_vect_type) :: y + end subroutine c_base_sctb_x + end interface + + interface + module subroutine c_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta + class(psb_c_base_vect_type) :: y + end subroutine c_base_sctb_buf + end interface + ! !> Function _base_addconst_a2 !! \memberof psb_c_base_vect_type @@ -2426,28 +1548,15 @@ contains !! \param b The added term !! \param info return code ! - subroutine c_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() -#if defined(PSB_OPENMP) - n = size(x) - !$omp parallel do private(i) - do i = 1, n - z%v(i) = x(i) + b - end do -#else - z%v = x + b -#endif - info = 0 - - end subroutine c_base_addconst_a2 + interface + module subroutine c_base_addconst_a2(x,b,z,info) + real(psb_spk_), intent(in) :: b + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_addconst_a2 + end interface + ! !> Function _base_addconst_v2 !! \memberof psb_c_base_vect_type @@ -2457,24 +1566,53 @@ contains !! \param b The added term !! \param info return code ! - subroutine c_base_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: b - class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%addconst(x%v,b,info) - end subroutine c_base_addconst_v2 + interface + module subroutine c_base_addconst_v2(x,b,z,info) + class(psb_c_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: b + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_addconst_v2 + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + complex(psb_spk_) :: x(:) + type(psb_c_base_vect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_c_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const + end module psb_c_base_vect_mod module psb_c_base_multivect_mod - use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_c_base_vect_mod @@ -2489,8 +1627,6 @@ module psb_c_base_multivect_mod !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private - public :: psb_c_base_multivect, psb_c_base_multivect_type type psb_c_base_multivect_type !> Values. @@ -2636,43 +1772,13 @@ module psb_c_base_multivect_mod generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_c_base_multivect_type + public :: psb_c_base_multivect, psb_c_base_multivect_type + interface psb_c_base_multivect module procedure constructor, size_const end interface psb_c_base_multivect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - complex(psb_spk_) :: x(:,:) - type(psb_c_base_multivect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),& - & size(x,dim=2,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_c_base_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(m,n,info) - - end function size_const + private ! ! Build from a sample @@ -2683,21 +1789,14 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine c_base_mlv_bld_x(x,this) - use psb_realloc_mod - complex(psb_spk_), intent(in) :: this(:,:) - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - - call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') - return - end if - x%v(:,:) = this(:,:) - - end subroutine c_base_mlv_bld_x - + interface + module subroutine c_base_mlv_bld_x(x,this) + complex(psb_spk_), intent(in) :: this(:,:) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + end subroutine c_base_mlv_bld_x + end interface + ! ! Create with size, but no initialization ! @@ -2707,18 +1806,15 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_mlv_bld_n(x,m,n,scratch) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: m,n - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch=scratch) - - end subroutine c_base_mlv_bld_n - + interface + module subroutine c_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + end subroutine c_base_mlv_bld_n + end interface + !> Function base_mlv_all: !! \memberof psb_c_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -2726,21 +1822,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine c_base_mlv_all(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_c_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(m,n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine c_base_mlv_all + interface + module subroutine c_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_all + end interface !> Function base_mlv_mold: !! \memberof psb_c_base_multivect_type @@ -2748,34 +1836,20 @@ contains !! \param y returned variable !! \param info return code !! - subroutine c_base_mlv_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - class(psb_c_base_multivect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_c_base_multivect_type :: y, stat=info) - - end subroutine c_base_mlv_mold - - subroutine c_base_mlv_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine c_base_mlv_mold(x, y, info) + class(psb_c_base_multivect_type), intent(in) :: x + class(psb_c_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_mold + end interface - info = 0 - if (allocated(x%v)) then - call x%sync() - x%v(:,:) = czero - call x%set_host() - call x%set_upd() - end if - - end subroutine c_base_mlv_reinit + interface + module subroutine c_base_mlv_reinit(x, info) + class(psb_c_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -2804,129 +1878,15 @@ contains !! \param info return code !! ! - subroutine c_base_mlv_ins(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - nc = size(x%v,2) - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_realloc(isz,nc,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k,:) = val(i,:) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_mlv_vect_ins') - return - end if - - end subroutine c_base_mlv_ins + interface + module subroutine c_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_ins + end interface ! !> Function base_mlv_zero @@ -2934,16 +1894,11 @@ contains !! \brief Zero out contents !! ! - subroutine c_base_mlv_zero(x) - use psi_serial_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) x%v=czero - call x%set_host() - - end subroutine c_base_mlv_zero - + interface + module subroutine c_base_mlv_zero(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_zero + end interface ! ! Assembly. @@ -2958,81 +1913,15 @@ contains !! \param info return code !! ! - - subroutine c_base_mlv_asb(m,n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - complex(psb_spk_), allocatable :: vv(:,:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(m,n,vv,info) - vv(:,:) = czero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i),:) = x%v(i,:) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (any(vv(x%iv(i),:).ne.czero)) then - info = psb_err_duplicate_coo - call psb_errpush(info,'mvect-asb') - return - else - vv(x%iv(i),:) = x%v(i,:) - end if - end do - case default - write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: @@ -3042,118 +1931,106 @@ contains !! \param info return code !! ! - subroutine c_base_mlv_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - - end subroutine c_base_mlv_free - - function c_base_mlv_get_ncfs(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function c_base_mlv_get_ncfs - - function c_base_mlv_get_dupl(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function c_base_mlv_get_dupl - - function c_base_mlv_get_state(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function c_base_mlv_get_state - - function c_base_mlv_is_null(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function c_base_mlv_is_null - - function c_base_mlv_is_bld(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function c_base_mlv_is_bld - - function c_base_mlv_is_upd(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function c_base_mlv_is_upd - - function c_base_mlv_is_asb(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function c_base_mlv_is_asb - - subroutine c_base_mlv_set_ncfs(n,x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine c_base_mlv_set_ncfs - - subroutine c_base_mlv_set_dupl(n,x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine c_base_mlv_set_dupl - - subroutine c_base_mlv_set_state(n,x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine c_base_mlv_set_state - - subroutine c_base_mlv_set_null(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine c_base_mlv_set_null - - subroutine c_base_mlv_set_bld(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine c_base_mlv_set_bld - - subroutine c_base_mlv_set_upd(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine c_base_mlv_set_upd - - subroutine c_base_mlv_set_asb(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine c_base_mlv_set_asb - + interface + module subroutine c_base_mlv_free(x, info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_free + end interface + + interface + module function c_base_mlv_get_ncfs(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_mlv_get_ncfs + end interface + + interface + module function c_base_mlv_get_dupl(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_mlv_get_dupl + end interface + + interface + module function c_base_mlv_get_state(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_mlv_get_state + end interface + + interface + module function c_base_mlv_is_null(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + end function c_base_mlv_is_null + end interface + + interface + module function c_base_mlv_is_bld(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + end function c_base_mlv_is_bld + end interface + + interface + module function c_base_mlv_is_upd(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + end function c_base_mlv_is_upd + end interface + + interface + module function c_base_mlv_is_asb(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + end function c_base_mlv_is_asb + end interface + + interface + module subroutine c_base_mlv_set_ncfs(n,x) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine c_base_mlv_set_ncfs + end interface + + interface + module subroutine c_base_mlv_set_dupl(n,x) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine c_base_mlv_set_dupl + end interface + + interface + module subroutine c_base_mlv_set_state(n,x) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine c_base_mlv_set_state + end interface + + interface + module subroutine c_base_mlv_set_null(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_null + end interface + + interface + module subroutine c_base_mlv_set_bld(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_bld + end interface + + interface + module subroutine c_base_mlv_set_upd(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_upd + end interface + + interface + module subroutine c_base_mlv_set_asb(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -3165,11 +2042,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine c_base_mlv_sync(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - end subroutine c_base_mlv_sync + interface + module subroutine c_base_mlv_sync(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_sync + end interface ! !> Function base_mlv_set_host: @@ -3177,11 +2054,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine c_base_mlv_set_host(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - end subroutine c_base_mlv_set_host + interface + module subroutine c_base_mlv_set_host(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_host + end interface ! !> Function base_mlv_set_dev: @@ -3189,11 +2066,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine c_base_mlv_set_dev(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - end subroutine c_base_mlv_set_dev + interface + module subroutine c_base_mlv_set_dev(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_dev + end interface ! !> Function base_mlv_set_sync: @@ -3201,11 +2078,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine c_base_mlv_set_sync(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - end subroutine c_base_mlv_set_sync + interface + module subroutine c_base_mlv_set_sync(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3213,13 +2090,12 @@ contains !! \brief Is vector on external device . !! ! - function c_base_mlv_is_dev(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - logical :: res - - res = .false. - end function c_base_mlv_is_dev + interface + module function c_base_mlv_is_dev(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + end function c_base_mlv_is_dev + end interface ! !> Function base_mlv_is_host @@ -3227,13 +2103,12 @@ contains !! \brief Is vector on standard memory . !! ! - function c_base_mlv_is_host(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function c_base_mlv_is_host + interface + module function c_base_mlv_is_host(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + end function c_base_mlv_is_host + end interface ! !> Function base_mlv_is_sync @@ -3241,35 +2116,25 @@ contains !! \brief Is vector on sync . !! ! - function c_base_mlv_is_sync(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function c_base_mlv_is_sync + interface + module function c_base_mlv_is_sync(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + end function c_base_mlv_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine c_base_mlv_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - class(psb_c_base_multivect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine c_base_mlv_cpy + interface + module subroutine c_base_mlv_cpy(x, y) + class(psb_c_base_multivect_type), intent(in) :: x + class(psb_c_base_multivect_type), intent(out) :: y + end subroutine c_base_mlv_cpy + end interface - - ! ! Size info. ! ! @@ -3278,25 +2143,19 @@ contains !! \brief Number of entries !! ! - function c_base_mlv_get_nrows(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function c_base_mlv_get_nrows + interface + module function c_base_mlv_get_nrows(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_mlv_get_nrows + end interface - function c_base_mlv_get_ncols(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,2) - - end function c_base_mlv_get_ncols + interface + module function c_base_mlv_get_ncols(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function c_base_mlv_get_ncols + end interface ! !> Function base_mlv_get_sizeof @@ -3304,15 +2163,12 @@ contains !! \brief Size in bytesa !! ! - function c_base_mlv_sizeof(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() * x%get_ncols() - - end function c_base_mlv_sizeof + interface + module function c_base_mlv_sizeof(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function c_base_mlv_sizeof + end interface ! !> Function base_mlv_get_fmt @@ -3320,12 +2176,11 @@ contains !! \brief Format !! ! - function c_base_mlv_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function c_base_mlv_get_fmt - + interface + module function c_base_mlv_get_fmt() result(res) + character(len=5) :: res + end function c_base_mlv_get_fmt + end interface ! ! @@ -3335,22 +2190,12 @@ contains !! \brief Extract a copy of the contents !! ! - function c_base_mlv_get_vect(x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - complex(psb_spk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info,m,n - m = x%get_nrows() - n = x%get_ncols() - if (.not.allocated(x%v)) return - call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') - return - end if - res(1:m,1:n) = x%v(1:m,1:n) - end function c_base_mlv_get_vect + interface + module function c_base_mlv_get_vect(x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:,:) + end function c_base_mlv_get_vect + end interface ! ! Reset all values @@ -3361,39 +2206,25 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine c_base_mlv_set_scal(x,val) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val - - integer(psb_ipk_) :: info - x%v = val - - end subroutine c_base_mlv_set_scal - + interface + module subroutine c_base_mlv_set_scal(x,val) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + end subroutine c_base_mlv_set_scal + end interface + ! !> Function base_mlv_set_vect !! \memberof psb_c_base_multivect_type !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine c_base_mlv_set_vect(x,val) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_) :: nr, nc - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - nr = min(size(x%v,1),size(val,1)) - nc = min(size(x%v,2),size(val,2)) - - x%v(1:nr,1:nc) = val(1:nr,1:nc) - else - x%v = val - end if - - end subroutine c_base_mlv_set_vect + interface + module subroutine c_base_mlv_set_vect(x,val) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:,:) + end subroutine c_base_mlv_set_vect + end interface ! ! Dot products @@ -3405,36 +2236,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_mlv_vect) to be multiplied by !! - function c_base_mlv_dot_v(n,x,y) result(res) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - complex(psb_spk_), allocatable :: res(:) - complex(psb_spk_), external :: cdotc - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - res = czero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_c_base_mlv_vect (or its class does not care). - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_c_base_multivect_type) - if (y%is_dev()) call y%sync() - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = cdotc(n,x%v(:,j),1,y%v(:,j),1) - end do - class default - res = y%dot(n,x%v) - end select - - end function c_base_mlv_dot_v + interface + module function c_base_mlv_dot_v(n,x,y) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_), allocatable :: res(:) + end function c_base_mlv_dot_v + end interface ! ! Base workhorse is good old BLAS1 @@ -3446,23 +2254,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function c_base_mlv_dot_a(n,x,y) result(res) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - complex(psb_spk_), intent(in) :: y(:,:) - integer(psb_ipk_), intent(in) :: n - complex(psb_spk_), allocatable :: res(:) - complex(psb_spk_), external :: cdotc - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = cdotc(n,x%v(:,j),1,y(:,j),1) - end do - - end function c_base_mlv_dot_a + interface + module function c_base_mlv_dot_a(n,x,y) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_), allocatable :: res(:) + end function c_base_mlv_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3478,30 +2277,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine c_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_c_base_multivect_type), intent(inout) :: x - class(psb_c_base_multivect_type), intent(inout) :: y - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - - if (present(n)) then - nc = n - else - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - end if - select type(xx => x) - type is (psb_c_base_multivect_type) - call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default - call y%axpby(m,alpha,x%v,beta,info,n=n) - end select - - end subroutine c_base_mlv_axpby_v + interface + module subroutine c_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine c_base_mlv_axpby_v + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3516,26 +2301,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine c_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - complex(psb_spk_), intent(in) :: x(:,:) - class(psb_c_base_multivect_type), intent(inout) :: y - complex(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - if (present(n)) then - nc = n - else - nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) - end if - - call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - - end subroutine c_base_mlv_axpby_a - + interface + module subroutine c_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:,:) + class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine c_base_mlv_axpby_a + end interface ! ! Multiple variants of two operations: @@ -3552,31 +2327,21 @@ contains !! \param x The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine c_base_mlv_mlt_mv(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - class(psb_c_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) + interface + module subroutine c_base_mlv_mlt_mv(x, y, info) + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_mlt_mv + end interface - end subroutine c_base_mlv_mlt_mv - - subroutine c_base_mlv_mlt_mv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine c_base_mlv_mlt_mv_v + interface + module subroutine c_base_mlv_mlt_mv_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_mlt_mv_v + end interface ! !> Function base_mlv_mlt_ar1 @@ -3585,22 +2350,14 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine c_base_mlv_mlt_ar1(x, y, info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: x(:) - class(psb_c_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n - y%v(i,:) = y%v(i,:)*x(i) - end do - - end subroutine c_base_mlv_mlt_ar1 - + interface + module subroutine c_base_mlv_mlt_ar1(x, y, info) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_mlt_ar1 + end interface + ! !> Function base_mlv_mlt_ar2 !! \memberof psb_c_base_multivect_type @@ -3608,21 +2365,13 @@ contains !! \param x(:,:) The array to be multiplied by !! \param info return code !! - subroutine c_base_mlv_mlt_ar2(x, y, info) - use psi_serial_mod - implicit none - complex(psb_spk_), intent(in) :: x(:,:) - class(psb_c_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr,nc - - info = 0 - nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) - nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) - y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - - end subroutine c_base_mlv_mlt_ar2 - + interface + module subroutine c_base_mlv_mlt_ar2(x, y, info) + complex(psb_spk_), intent(in) :: x(:,:) + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_mlt_ar2 + end interface ! !> Function base_mlv_mlt_a_2 @@ -3635,54 +2384,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine c_base_mlv_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_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr, nc - - info = 0 - nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == czero) then - if (beta == cone) then - return - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - end if - else - if (alpha == cone) then - if (beta == czero) then - z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == cone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else if (alpha == -cone) then - if (beta == czero) then - z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == cone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else - if (beta == czero) then - z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == cone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - end if - end if - end if - end subroutine c_base_mlv_mlt_a_2 - + interface + module subroutine c_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_mlt_a_2 + end interface + ! !> Function base_mlv_mlt_v_2 !! \memberof psb_c_base_multivect_type @@ -3694,41 +2405,18 @@ contains !! \param y The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine c_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - complex(psb_spk_), intent(in) :: alpha,beta - class(psb_c_base_multivect_type), intent(inout) :: x - class(psb_c_base_multivect_type), intent(inout) :: y - class(psb_c_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - if (z%is_dev()) call z%sync() - if (.not.psb_c_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - end if - end subroutine c_base_mlv_mlt_v_2 + interface + module subroutine c_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_spk_), intent(in) :: alpha,beta + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_c_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine c_base_mlv_mlt_v_2 + end interface !!$ !!$ subroutine c_base_mlv_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_base_multivect_type), intent(inout) :: y @@ -3743,8 +2431,6 @@ contains !!$ end subroutine c_base_mlv_mlt_av !!$ !!$ subroutine c_base_mlv_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_base_multivect_type), intent(inout) :: x @@ -3767,17 +2453,13 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine c_base_mlv_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - complex(psb_spk_), intent (in) :: alpha - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) x%v = alpha*x%v - - end subroutine c_base_mlv_scal - + interface + module subroutine c_base_mlv_scal(alpha, x) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent (in) :: alpha + end subroutine c_base_mlv_scal + end interface + ! ! Norms 1, 2 and infinity ! @@ -3785,64 +2467,40 @@ contains !! \memberof psb_c_base_multivect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function c_base_mlv_nrm2(n,x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - real(psb_spk_), external :: scnrm2 - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = scnrm2(n,x%v(:,j),1) - end do - - end function c_base_mlv_nrm2 + interface + module function c_base_mlv_nrm2(n,x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function c_base_mlv_nrm2 + end interface ! !> Function base_mlv_amax !! \memberof psb_c_base_multivect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function c_base_mlv_amax(n,x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = maxval(abs(x%v(1:n,j))) - end do - - end function c_base_mlv_amax - + interface + module function c_base_mlv_amax(n,x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function c_base_mlv_amax + end interface + ! !> Function base_mlv_asum !! \memberof psb_c_base_multivect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function c_base_mlv_asum(n,x) result(res) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = sum(abs(x%v(1:n,j))) - end do - - end function c_base_mlv_asum + interface + module function c_base_mlv_asum(n,x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function c_base_mlv_asum + end interface + ! ! Overwrite with absolute value ! @@ -3851,96 +2509,63 @@ contains !! \memberof psb_c_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine c_base_mlv_absval1(x) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v = abs(x%v) - call x%set_host() - end if - - end subroutine c_base_mlv_absval1 - - subroutine c_base_mlv_absval2(x,y) - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - class(psb_c_base_multivect_type), intent(inout) :: y - integer(psb_ipk_) :: info - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) then - call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) - call y%absval() - end if - - end subroutine c_base_mlv_absval2 - - - function c_base_mlv_use_buffer() result(res) - implicit none - logical :: res - - res = .true. - end function c_base_mlv_use_buffer - - subroutine c_base_mlv_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: nc - nc = x%get_ncols() - call psb_realloc(n*nc,x%combuf,info) - end subroutine c_base_mlv_new_buffer - - subroutine c_base_mlv_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine c_base_mlv_new_comid - - - subroutine c_base_mlv_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine c_base_mlv_maybe_free_buffer - - subroutine c_base_mlv_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine c_base_mlv_free_buffer - - subroutine c_base_mlv_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine c_base_mlv_free_comid + interface + module subroutine c_base_mlv_absval1(x) + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_absval1 + end interface + + interface + module subroutine c_base_mlv_absval2(x,y) + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + end subroutine c_base_mlv_absval2 + end interface + + + interface + module function c_base_mlv_use_buffer() result(res) + logical :: res + end function c_base_mlv_use_buffer + end interface + + interface + module subroutine c_base_mlv_new_buffer(n,x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_new_buffer + end interface + + interface + module subroutine c_base_mlv_new_comid(n,x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_new_comid + end interface + + interface + module subroutine c_base_mlv_maybe_free_buffer(x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_maybe_free_buffer + end interface + + interface + module subroutine c_base_mlv_free_buffer(x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_free_buffer + end interface + interface + module subroutine c_base_mlv_free_comid(x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_mlv_free_comid + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -3954,23 +2579,14 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine c_base_mlv_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: alpha, beta, y(:) - class(psb_c_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - call psi_gth(n,nc,idx,alpha,x%v,beta,y) - - end subroutine c_base_mlv_gthab + interface + module subroutine c_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_base_multivect_type) :: x + end subroutine c_base_mlv_gthab + end interface ! ! shortcut alpha=1 beta=0 ! @@ -3980,19 +2596,15 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine c_base_mlv_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_spk_) :: y(:) - class(psb_c_base_multivect_type) :: x - - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine c_base_mlv_gthzv_x + interface + module subroutine c_base_mlv_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_base_multivect_type) :: x + end subroutine c_base_mlv_gthzv_x + end interface ! ! shortcut alpha=1 beta=0 @@ -4003,24 +2615,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine c_base_mlv_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: y(:) - class(psb_c_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine c_base_mlv_gthzv + interface + module subroutine c_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_base_multivect_type) :: x + end subroutine c_base_mlv_gthzv + end interface ! ! shortcut alpha=1 beta=0 ! @@ -4030,48 +2632,27 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine c_base_mlv_gthzm(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: y(:,:) - class(psb_c_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine c_base_mlv_gthzm + interface + module subroutine c_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:,:) + class(psb_c_base_multivect_type) :: x + end subroutine c_base_mlv_gthzm + end interface ! ! New comm internals impl. ! - subroutine c_base_mlv_gthzbuf(i,ixb,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, ixb - class(psb_i_base_vect_type) :: idx - class(psb_c_base_multivect_type) :: x - integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - nc = x%get_ncols() - call x%gth(n,idx%v(i:),x%combuf(ixb:)) - - end subroutine c_base_mlv_gthzbuf - + interface + module subroutine c_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_c_base_multivect_type) :: x + end subroutine c_base_mlv_gthzbuf + end interface + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -4085,72 +2666,43 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine c_base_mlv_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: beta, x(:) - class(psb_c_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = psb_size(y%v,2_psb_ipk_) - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine c_base_mlv_sctb - - subroutine c_base_mlv_sctbr2(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_spk_) :: beta, x(:,:) - class(psb_c_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = y%get_ncols() - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine c_base_mlv_sctbr2 - - subroutine c_base_mlv_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex( psb_spk_) :: beta, x(:) - class(psb_c_base_multivect_type) :: y - - call y%sct(n,idx%v(i:),x,beta) - - end subroutine c_base_mlv_sctb_x - - subroutine c_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, iyb - class(psb_i_base_vect_type) :: idx - complex(psb_spk_) :: beta - class(psb_c_base_multivect_type) :: y - integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - nc = y%get_ncols() - call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) - call y%set_host() - - end subroutine c_base_mlv_sctb_buf + interface + module subroutine c_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_base_multivect_type) :: y + end subroutine c_base_mlv_sctb + end interface + + interface + module subroutine c_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:,:) + class(psb_c_base_multivect_type) :: y + end subroutine c_base_mlv_sctbr2 + end interface + + interface + module subroutine c_base_mlv_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_base_multivect_type) :: y + end subroutine c_base_mlv_sctb_x + end interface + + interface + module subroutine c_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta + class(psb_c_base_multivect_type) :: y + end subroutine c_base_mlv_sctb_buf + end interface ! !> Function base_device_wait: @@ -4158,9 +2710,43 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine c_base_mlv_device_wait() - implicit none + interface + module subroutine c_base_mlv_device_wait() + end subroutine c_base_mlv_device_wait + end interface - end subroutine c_base_mlv_device_wait +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + complex(psb_spk_) :: x(:,:) + type(psb_c_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_c_base_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(m,n,info) + + end function size_const end module psb_c_base_multivect_mod diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index 7f6c1c6cf..3c6d7919b 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -161,7 +161,10 @@ module psb_c_vect_mod end type psb_c_vect_type - public :: psb_c_vect + public :: psb_c_vect, psb_c_vect_type,& + & psb_c_set_vect_default, psb_c_get_vect_default, & + & psb_c_clear_vect_default, psb_c_base_vect_type + private :: constructor, size_const interface psb_c_vect module procedure constructor, size_const @@ -188,180 +191,713 @@ module psb_c_vect_mod class(psb_c_base_vect_type), allocatable, target,& & save, private :: psb_c_base_vect_default - interface psb_set_vect_default - module procedure psb_c_set_vect_default - end interface psb_set_vect_default - - interface psb_get_vect_default - module procedure psb_c_get_vect_default - end interface psb_get_vect_default - - -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 + interface + module function c_vect_get_dupl(x) result(res) + 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 + 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 + 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 + - 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 + 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 + - 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 + 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 - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine c_vect_set_remote_build - +contains + 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 @@ -372,7 +908,6 @@ contains 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 @@ -381,7 +916,6 @@ contains 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) @@ -390,7 +924,6 @@ contains 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 @@ -401,150 +934,6 @@ contains 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,908 +955,6 @@ 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 y%v%div(x%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 y%v%div(x%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 @@ -1477,7 +964,6 @@ module psb_c_multivect_mod use psb_const_mod use psb_i_vect_mod - !private type psb_c_multivect_type @@ -1540,422 +1026,231 @@ module psb_c_multivect_mod end type psb_c_multivect_type public :: psb_c_multivect, psb_c_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default, & - & psb_c_base_multivect_type + & psb_c_set_multivect_default, psb_c_get_base_multivect_default, & + & psb_c_clear_multivect_default, psb_c_base_multivect_type - private interface psb_c_multivect module procedure constructor, size_const end interface psb_c_multivect + private + 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 - + 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 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 - 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 + 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 + integer(psb_ipk_) :: info + end subroutine c_mvect_cnv + end interface -!!$ function c_mvect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ module function c_mvect_dot_v(n,x,y) result(res) !!$ class(psb_c_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_spk_) :: res @@ -1967,7 +1262,6 @@ contains !!$ end function c_mvect_dot_v !!$ !!$ 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 @@ -1979,9 +1273,7 @@ contains !!$ !!$ end function c_mvect_dot_a !!$ -!!$ subroutine c_mvect_axpby_v(m,alpha, x, beta, y, info) -!!$ use psi_serial_mod -!!$ implicit none +!!$ module subroutine c_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: y @@ -1997,8 +1289,6 @@ contains !!$ end subroutine c_mvect_axpby_v !!$ !!$ 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 @@ -2012,8 +1302,6 @@ contains !!$ !!$ !!$ 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 @@ -2026,8 +1314,6 @@ contains !!$ end subroutine c_mvect_mlt_v !!$ !!$ 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 @@ -2042,8 +1328,6 @@ contains !!$ !!$ !!$ 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(:) @@ -2058,8 +1342,6 @@ contains !!$ end subroutine c_mvect_mlt_a_2 !!$ !!$ 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 @@ -2077,8 +1359,6 @@ contains !!$ end subroutine c_mvect_mlt_v_2 !!$ !!$ 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 @@ -2093,8 +1373,6 @@ contains !!$ end subroutine c_mvect_mlt_av !!$ !!$ 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 @@ -2110,8 +1388,6 @@ contains !!$ end subroutine c_mvect_mlt_va !!$ !!$ 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 !!$ @@ -2121,7 +1397,6 @@ contains !!$ !!$ !!$ 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 @@ -2135,7 +1410,6 @@ contains !!$ end function c_mvect_nrm2 !!$ !!$ 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 @@ -2149,7 +1423,6 @@ contains !!$ end function c_mvect_amax !!$ !!$ 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 @@ -2162,4 +1435,65 @@ contains !!$ !!$ end function c_mvect_asum +contains + + subroutine psb_c_set_multivect_default(v) + 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) +!!$ 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) + 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 + + 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 + + + subroutine psb_c_clear_multivect_default() + + if (allocated(psb_c_base_multivect_default)) then + deallocate(psb_c_base_multivect_default) + end if + + end subroutine psb_c_clear_multivect_default + end module psb_c_multivect_mod diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index ad77c62a4..983a44ddd 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -253,45 +253,12 @@ module psb_d_base_vect_mod end type psb_d_base_vect_type - public :: psb_d_base_vect + public :: psb_d_base_vect, psb_d_base_vect_type private :: constructor, size_const interface psb_d_base_vect module procedure constructor, size_const end interface psb_d_base_vect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - real(psb_dpk_) :: x(:) - type(psb_d_base_vect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(n) result(this) - integer(psb_ipk_), intent(in) :: n - type(psb_d_base_vect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(n,info) - - end function size_const - ! ! Build from a sample ! @@ -301,36 +268,13 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine d_base_bld_x(x,this,scratch) - use psb_realloc_mod - implicit none - real(psb_dpk_), intent(in) :: this(:) - class(psb_d_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - integer(psb_ipk_) :: i - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(size(this),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') - return - end if -#if defined (PSB_OPENMP) - !$omp parallel do private(i) - do i = 1, size(this) - x%v(i) = this(i) - end do -#else - x%v(:) = this(:) -#endif - end subroutine d_base_bld_x + interface + module subroutine d_base_bld_x(x,this,scratch) + real(psb_dpk_), intent(in) :: this(:) + class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine d_base_bld_x + end interface ! ! Create with size, but no initialization @@ -341,50 +285,26 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_bld_mn(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_d_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine d_base_bld_mn - + interface + module subroutine d_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine d_base_bld_mn + end interface + !> Function bld_en: !! \memberof psb_d_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_bld_en(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_d_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine d_base_bld_en + interface + module subroutine d_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine d_base_bld_en + end interface !> Function base_all: !! \memberof psb_d_base_vect_type @@ -393,21 +313,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine d_base_all(n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_d_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine d_base_all + interface + module subroutine d_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_d_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_all + end interface !> Function base_mold: !! \memberof psb_d_base_vect_type @@ -415,42 +327,21 @@ contains !! \param y returned variable !! \param info return code !! - subroutine d_base_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(in) :: x - class(psb_d_base_vect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_d_base_vect_type :: y, stat=info) - - end subroutine d_base_mold - - subroutine d_base_reinit(x, info,clear) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - logical :: clear_ - - info = 0 - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - if (clear_) x%v(:) = dzero - call x%set_host() - call x%set_upd() - end if - - end subroutine d_base_reinit + interface + module subroutine d_base_mold(x, y, info) + class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mold + end interface + + interface + module subroutine d_base_reinit(x, info,clear) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine d_base_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -479,152 +370,27 @@ contains !! \param info return code !! ! - subroutine d_base_ins_a(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine d_base_ins_a - - subroutine d_base_ins_v(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - class(psb_i_base_vect_type), intent(inout) :: irl - class(psb_d_base_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: isz - - info = 0 - if (psb_errstatus_fatal()) return - - if (irl%is_dev()) call irl%sync() - if (val%is_dev()) call val%sync() - if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,maxr,info) - - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine d_base_ins_v + interface + module subroutine d_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_ins_a + end interface + + + interface + module subroutine d_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_d_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_ins_v + end interface + ! @@ -633,18 +399,12 @@ contains !! \brief Zero out contents !! ! - subroutine d_base_zero(x) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x + interface + module subroutine d_base_zero(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_zero + end interface - if (allocated(x%v)) then - !$omp workshare - x%v(:)=dzero - !$omp end workshare - end if - call x%set_host() - end subroutine d_base_zero ! @@ -661,74 +421,15 @@ contains !! ! - subroutine d_base_asb_m(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - real(psb_dpk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(n,vv,info) - vv(:) = dzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (vv(x%iv(i)).ne. dzero) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine d_base_asb_m + interface + module subroutine d_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine d_base_asb_m + end interface + ! ! Assembly. @@ -744,74 +445,15 @@ contains !! ! - subroutine d_base_asb_e(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - real(psb_dpk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') - if (x%is_bld()) then - call psb_realloc(n,vv,info) - vv(:) = dzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne. dzero) then - call psb_errpush(psb_err_duplicate_coo,'vect_asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine d_base_asb_e + interface + module subroutine d_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine d_base_asb_e + end interface + ! !> Function base_free: @@ -821,22 +463,13 @@ contains !! \param info return code !! ! - subroutine d_base_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine d_base_free(x, info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_free + end interface - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - call x%set_null() - end subroutine d_base_free ! !> Function base_free_buffer: @@ -846,15 +479,13 @@ contains !! \param info return code !! ! - subroutine d_base_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine d_base_free_buffer(x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_free_buffer + end interface - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine d_base_free_buffer ! !> Function base_maybe_free_buffer: @@ -867,17 +498,13 @@ contains !! \param info return code !! ! - subroutine d_base_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine d_base_maybe_free_buffer(x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_maybe_free_buffer + end interface - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine d_base_maybe_free_buffer ! !> Function base_free_comid: @@ -887,113 +514,107 @@ contains !! \param info return code !! ! - subroutine d_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine d_base_free_comid - - function d_base_get_ncfs(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function d_base_get_ncfs - - function d_base_get_dupl(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function d_base_get_dupl - - function d_base_get_state(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function d_base_get_state - - function d_base_is_null(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function d_base_is_null - - function d_base_is_bld(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function d_base_is_bld - - function d_base_is_upd(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function d_base_is_upd - - function d_base_is_asb(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function d_base_is_asb - - subroutine d_base_set_ncfs(n,x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine d_base_set_ncfs - - subroutine d_base_set_dupl(n,x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine d_base_set_dupl - - subroutine d_base_set_state(n,x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine d_base_set_state - - subroutine d_base_set_null(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine d_base_set_null - - subroutine d_base_set_bld(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine d_base_set_bld - - subroutine d_base_set_upd(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine d_base_set_upd - - subroutine d_base_set_asb(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine d_base_set_asb + interface + module subroutine d_base_free_comid(x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_free_comid + end interface + + + interface + module function d_base_get_ncfs(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_get_ncfs + end interface + + interface + module function d_base_get_dupl(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_get_dupl + end interface + + interface + module function d_base_get_state(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_get_state + end interface + + interface + module function d_base_is_null(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + end function d_base_is_null + end interface + + interface + module function d_base_is_bld(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + end function d_base_is_bld + end interface + + interface + module function d_base_is_upd(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + end function d_base_is_upd + end interface + + interface + module function d_base_is_asb(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + end function d_base_is_asb + end interface + + interface + module subroutine d_base_set_ncfs(n,x) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine d_base_set_ncfs + end interface + + interface + module subroutine d_base_set_dupl(n,x) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine d_base_set_dupl + end interface + + interface + module subroutine d_base_set_state(n,x) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine d_base_set_state + end interface + + interface + module subroutine d_base_set_null(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_set_null + end interface + + interface + module subroutine d_base_set_bld(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_set_bld + end interface + + interface + module subroutine d_base_set_upd(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_set_upd + end interface + + interface + module subroutine d_base_set_asb(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -1005,11 +626,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine d_base_sync(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - end subroutine d_base_sync + interface + module subroutine d_base_sync(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_sync + end interface ! !> Function base_set_host: @@ -1017,11 +638,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine d_base_set_host(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - end subroutine d_base_set_host + interface + module subroutine d_base_set_host(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_set_host + end interface ! !> Function base_set_dev: @@ -1029,11 +650,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine d_base_set_dev(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - end subroutine d_base_set_dev + interface + module subroutine d_base_set_dev(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_set_dev + end interface ! !> Function base_set_sync: @@ -1041,11 +662,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine d_base_set_sync(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - end subroutine d_base_set_sync + interface + module subroutine d_base_set_sync(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_set_sync + end interface ! !> Function base_is_dev: @@ -1053,13 +674,12 @@ contains !! \brief Is vector on external device . !! ! - function d_base_is_dev(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - logical :: res - - res = .false. - end function d_base_is_dev + interface + module function d_base_is_dev(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + end function d_base_is_dev + end interface ! !> Function base_is_host @@ -1067,13 +687,12 @@ contains !! \brief Is vector on standard memory . !! ! - function d_base_is_host(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function d_base_is_host + interface + module function d_base_is_host(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + end function d_base_is_host + end interface ! !> Function base_is_sync @@ -1081,32 +700,24 @@ contains !! \brief Is vector on sync . !! ! - function d_base_is_sync(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function d_base_is_sync + interface + module function d_base_is_sync(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + end function d_base_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine d_base_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(in) :: x - class(psb_d_base_vect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine d_base_cpy + interface + module subroutine d_base_cpy(x, y) + class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(out) :: y + end subroutine d_base_cpy + end interface ! ! Size info. @@ -1117,15 +728,12 @@ contains !! \brief Number of entries !! ! - function d_base_get_nrows(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v) - - end function d_base_get_nrows + interface + module function d_base_get_nrows(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_get_nrows + end interface ! !> Function base_get_sizeof @@ -1133,15 +741,12 @@ contains !! \brief Size in bytes !! ! - function d_base_sizeof(x) result(res) - implicit none - class(psb_d_base_vect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() - - end function d_base_sizeof + interface + module function d_base_sizeof(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function d_base_sizeof + end interface ! !> Function base_get_fmt @@ -1149,12 +754,11 @@ contains !! \brief Format !! ! - function d_base_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function d_base_get_fmt - + interface + module function d_base_get_fmt() result(res) + character(len=5) :: res + end function d_base_get_fmt + end interface ! ! @@ -1164,34 +768,14 @@ contains !! \brief Extract a copy of the contents !! ! - function d_base_get_vect(x,n) result(res) - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - ! Local variables - integer(psb_ipk_) :: isz, i - - if (.not.allocated(x%v)) return - if (.not.x%is_host()) call x%sync() - isz = x%get_nrows() - if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') - return - end if - if (.false.) then - res(1:isz) = x%v(1:isz) - else - !$omp parallel do private(i) - do i=1, isz - res(i) = x%v(i) - end do - end if - - end function d_base_get_vect - + interface + module function d_base_get_vect(x,n) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function d_base_get_vect + end interface + ! ! Reset all values ! @@ -1201,32 +785,13 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine d_base_set_scal(x,val,first,last) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i - - first_=1 - last_=size(x%v) - if (present(first)) first_ = max(1,first) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val - end do -#else - x%v(first_:last_) = val -#endif - call x%set_host() - - end subroutine d_base_set_scal - + interface + module subroutine d_base_set_scal(x,val,first,last) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine d_base_set_scal + end interface ! !> Function base_set_vect @@ -1234,45 +799,20 @@ contains !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine d_base_set_vect(x,val,first,last) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i, info - - if (.not.allocated(x%v)) then - call psb_realloc(size(val),x%v,info) - end if - - first_ = 1 - if (present(first)) first_ = max(1,first) - last_ = min(psb_size(x%v),first_+size(val)-1) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() - -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val(i-first_+1) - end do -#else - x%v(first_:last_) = val(1:last_-first_+1) -#endif - call x%set_host() - - end subroutine d_base_set_vect - - subroutine d_base_check_addr(x) - class(psb_d_base_vect_type), intent(inout) :: x - - write(0,*) 'Check addr: base version, do nothing' - - end subroutine d_base_check_addr - - + interface + module subroutine d_base_set_vect(x,val,first,last) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine d_base_set_vect + end interface + + interface + module subroutine d_base_check_addr(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_check_addr + end interface + ! ! Get entry. ! @@ -1282,33 +822,22 @@ contains !! \brief Get one entry from the vector !! ! - 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 - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - res = x%v(index) - end if - - end function d_base_get_entry - - subroutine d_base_set_entry(x, index, val) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_dpk_) :: val - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v(index) =val - call x%set_host() - end if - end subroutine d_base_set_entry - + interface + module function d_base_get_entry(x, index) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: res + end function d_base_get_entry + end interface + + interface + module subroutine d_base_set_entry(x, index, val) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + end subroutine d_base_set_entry + end interface + ! ! Overwrite with absolute value ! @@ -1317,40 +846,19 @@ contains !! \memberof psb_d_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine d_base_absval1(x) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: i - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1, size(x%v) - x%v(i) = abs(x%v(i)) - end do -#else - x%v = abs(x%v) -#endif - call x%set_host() - end if - - end subroutine d_base_absval1 - - subroutine d_base_absval2(x,y) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_) :: info - if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then - call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) - call y%absval() - end if - - end subroutine d_base_absval2 - + interface + module subroutine d_base_absval1(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_absval1 + end interface + + interface + module subroutine d_base_absval2(x,y) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + end subroutine d_base_absval2 + end interface + ! ! Dot products ! @@ -1361,29 +869,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_vect) to be multiplied by !! - function d_base_dot_v(n,x,y) result(res) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - real(psb_dpk_), external :: ddot - - res = dzero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_d_base_vect. - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_d_base_vect_type) - res = ddot(n,x%v,1,y%v,1) - class default - res = y%dot(n,x%v) - end select - - end function d_base_dot_v + interface + module function d_base_dot_v(n,x,y) result(res) + class(psb_d_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function + end interface ! ! Base workhorse is good old BLAS1 @@ -1395,17 +887,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function d_base_dot_a(n,x,y) result(res) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - real(psb_dpk_), external :: ddot - - res = ddot(n,y,1,x%v,1) - - end function d_base_dot_a + interface + module function d_base_dot_a(n,x,y) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_base_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1421,20 +910,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine d_base_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call y%axpby(m,alpha,x%v,beta,info) - - end subroutine d_base_axpby_v + interface + module subroutine d_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_axpby_v + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1452,21 +936,16 @@ contains !! \param z The class(base_vect) to be returned !! \param info return code !! - subroutine d_base_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - class(psb_d_base_vect_type), intent(inout) :: z - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call z%axpby(m,alpha,x%v,beta,y%v,info) - - end subroutine d_base_axpby_v2 + interface + module subroutine d_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_axpby_v2 + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1481,20 +960,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine d_base_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_base_vect_type), intent(inout) :: y - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (y%is_dev()) call y%sync() - call psb_geaxpby(m,alpha,x,beta,y%v,info) - call y%set_host() - - end subroutine d_base_axpby_a + interface + module subroutine d_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_axpby_a + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1510,21 +984,16 @@ contains !! \param y(:) The array to be added !! \param info return code !! - subroutine d_base_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_base_vect_type), intent(inout) :: z - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (z%is_dev()) call z%sync() - call psb_geaxpby(m,alpha,x,beta,y,z%v,info) - call z%set_host() - - end subroutine d_base_axpby_a2 + interface + module subroutine d_base_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_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_axpby_a2 + end interface ! ! UPD_XYZ is invoked via Z, hence the structure below. @@ -1543,48 +1012,29 @@ contains !! \param z The class(base_vect) to be added !! \param info return code !! - subroutine d_base_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_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - class(psb_d_base_vect_type), intent(inout) :: z - real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(alpha/=dzero)) call x%sync() - if (y%is_dev().and.(beta/=dzero)) call y%sync() - if (z%is_dev().and.(delta/=dzero)) call z%sync() - call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) - call y%set_host() - call z%set_host() - - end subroutine d_base_upd_xyz - - subroutine d_base_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_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - class(psb_d_base_vect_type), intent(inout) :: z - class(psb_d_base_vect_type), intent(inout) :: w - real(psb_dpk_), intent (in) :: a,b,c,d,e,f - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(a/=dzero)) call x%sync() - if (y%is_dev().and.(b/=dzero)) call y%sync() - if (z%is_dev().and.(d/=dzero)) call z%sync() - if (w%is_dev().and.(f/=dzero)) call w%sync() - call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) - call y%set_host() - call z%set_host() - call w%set_host() - - end subroutine d_base_xyzw - - + interface + module subroutine d_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_upd_xyz + end interface + + interface + module subroutine d_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + class(psb_d_base_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_base_xyzw + end interface + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -1600,20 +1050,14 @@ contains !! \param x The class(base_vect) to be multiplied by !! \param info return code !! - subroutine d_base_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine d_base_mlt_v - + interface + module subroutine d_base_mlt_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlt_v + end interface + ! !> Function base_mlt_a !! \memberof psb_d_base_vect_type @@ -1621,25 +1065,13 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine d_base_mlt_a(x, y, info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: x(:) - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)*x(i) - end do - call y%set_host() - - end subroutine d_base_mlt_a - + interface + module subroutine d_base_mlt_a(x, y, info) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlt_a + end interface ! !> Function base_mlt_a_2 @@ -1652,87 +1084,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine d_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(z%v), size(x), size(y)) - if (alpha == dzero) then - if (beta == done) then - return - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - end do - end if - else - if (alpha == done) then - if (beta == dzero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = y(i)*x(i) - end do - else if (beta == done) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) + y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) + y(i)*x(i) - end do - end if - else if (alpha == -done) then - if (beta == dzero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = -y(i)*x(i) - end do - else if (beta == done) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) - y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - y(i)*x(i) - end do - end if - else - if (beta == dzero) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = alpha*y(i)*x(i) - end do - else if (beta == done) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = z%v(i) + alpha*y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(alpha, beta) - do i=1, n - z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) - end do - end if - end if - end if - call z%set_host() - - end subroutine d_base_mlt_a_2 - + interface + module subroutine d_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlt_a_2 + end interface + ! !> Function base_mlt_v_2 !! \memberof psb_d_base_vect_type @@ -1744,68 +1105,37 @@ contains !! \param y The class(base_vect) to be multiplied by !! \param info return code !! - subroutine d_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - real(psb_dpk_), intent(in) :: alpha,beta - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (y%is_dev()) call y%sync() - if (x%is_dev()) call x%sync() - if (.not.psb_d_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - end if - end subroutine d_base_mlt_v_2 - - subroutine d_base_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_base_vect_type), intent(inout) :: y - class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call z%mlt(alpha,x,y%v,beta,info) - - end subroutine d_base_mlt_av - - subroutine d_base_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_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call z%mlt(alpha,y,x,beta,info) - - end subroutine d_base_mlt_va + interface + module subroutine d_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_dpk_), intent(in) :: alpha,beta + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine d_base_mlt_v_2 + end interface + + interface + module subroutine d_base_mlt_av(alpha,x,y,beta,z,info) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlt_av + end interface + + interface + module subroutine d_base_mlt_va(alpha,x,y,beta,z,info) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlt_va + end interface + ! !> Function base_div_v !! \memberof psb_d_base_vect_type @@ -1813,38 +1143,22 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine d_base_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%div(x%v,info) - - end subroutine d_base_div_v - - subroutine d_base_div_a(x, y, info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: x(:) - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)/x(i) - end do - call y%set_host() - - end subroutine d_base_div_a + interface + module subroutine d_base_div_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_div_v + end interface + + interface + module subroutine d_base_div_a(x, y, info) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_div_a + end interface + ! !> Function base_div_v2 !! \memberof psb_d_base_vect_type @@ -1852,21 +1166,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine d_base_div_v2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call z%div(x%v,y%v,info) - call z%set_host() - end subroutine d_base_div_v2 + interface + module subroutine d_base_div_v2(x, y, z, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_div_v2 + end interface + ! !> Function base_div_v_check !! \memberof psb_d_base_vect_type @@ -1874,21 +1182,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine d_base_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call x%div(x%v,y%v,info,flag) - - end subroutine d_base_div_v_check + interface + module subroutine d_base_div_v_check(x, y, info, flag) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_base_div_v_check + end interface + ! !> Function base_div_v2_check !! \memberof psb_d_base_vect_type @@ -1896,21 +1198,16 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine d_base_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info,flag) - - end subroutine d_base_div_v2_check + interface + module subroutine d_base_div_v2_check(x, y, z, info, flag) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_base_div_v2_check + end interface + ! !> Function base_div_a2 !! \memberof psb_d_base_vect_type @@ -1918,25 +1215,15 @@ contains !! \param y(:) The array to be divided by !! \param info return code !! - subroutine d_base_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: z - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - !$omp parallel do private(i) - do i=1, n - z%v(i) = x(i)/y(i) - end do - - end subroutine d_base_div_a2 + interface + module subroutine d_base_div_a2(x, y, z, info) + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_div_a2 + end interface + ! !> Function base_div_a2_check !! \memberof psb_d_base_vect_type @@ -1945,35 +1232,16 @@ contains !! \param y(:) The array to be dived by !! \param info return code !! - subroutine d_base_div_a2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: z - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call d_base_div_a2(x, y, z, info) - else - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - ! $omp parallel do private(i) - do i=1, n - if (y(i) /= 0) then - z%v(i) = x(i)/y(i) - else - info = 1 - exit - end if - end do - end if - - end subroutine d_base_div_a2_check + interface + module subroutine d_base_div_a2_check(x, y, z, info, flag) + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_base_div_a2_check + end interface + ! !> Function base_inv_v !! \memberof psb_d_base_vect_type @@ -1981,20 +1249,14 @@ contains !! \param x The vector to be inverted !! \param y The vector containing the inverted vector !! \param info return code - subroutine d_base_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info) - - - end subroutine d_base_inv_v + interface + module subroutine d_base_inv_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_inv_v + end interface + ! !> Function base_inv_v_check !! \memberof psb_d_base_vect_type @@ -2003,20 +1265,16 @@ contains !! \param y The vector containing the inverted vector !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v - subroutine d_base_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info,flag) - - end subroutine d_base_inv_v_check + interface + module subroutine d_base_inv_v_check(x, y, info, flag) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + end subroutine d_base_inv_v_check + end interface + ! !> Function base_inv_a2 !! \memberof psb_d_base_vect_type @@ -2025,24 +1283,14 @@ contains !! \param y The vector containing the inverted vector !! \param info return code ! - subroutine d_base_inv_a2(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: y - real(psb_dpk_), intent(in) :: x(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - y%v(i) = 1_psb_dpk_/x(i) - end do - - end subroutine d_base_inv_a2 + interface + module subroutine d_base_inv_a2(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_inv_a2 + end interface + ! !> Function base_inv_a2_check !! \memberof psb_d_base_vect_type @@ -2052,35 +1300,14 @@ contains !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v ! - subroutine d_base_inv_a2_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: y - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call d_base_inv_a2(x, y, info) - else - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - if (x(i) /= 0) then - y%v(i) = 1_psb_dpk_/x(i) - else - info = 1 - y%v(i) = 0_psb_dpk_ - end if - end do - end if - - - end subroutine d_base_inv_a2_check + interface + module subroutine d_base_inv_a2_check(x, y, info, flag) + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine d_base_inv_a2_check + end interface ! !> Function base_inv_a2_check @@ -2091,29 +1318,15 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine d_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() - - n = size(x) - !$omp parallel do private(i) - do i = 1, n, 1 - if ( abs(x(i)).ge.c ) then - z%v(i) = 1_psb_dpk_ - else - z%v(i) = 0_psb_dpk_ - end if - end do - info = 0 - - end subroutine d_base_acmp_a2 + interface + module subroutine d_base_acmp_a2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_acmp_a2 + end interface + ! !> Function base_cmp_v2 !! \memberof psb_d_base_vect_type @@ -2123,18 +1336,14 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine d_base_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: c - class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%acmp(x%v,c,info) - end subroutine d_base_acmp_v2 + interface + module subroutine d_base_acmp_v2(x,c,z,info) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_acmp_v2 + end interface ! ! Simple scaling @@ -2144,25 +1353,12 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine d_base_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent (in) :: alpha - integer(psb_ipk_) :: i - - if (allocated(x%v)) then -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1,size(x%v) - x%v(i) = alpha*x%v(i) - end do -#else - x%v = alpha*x%v -#endif - end if - call x%set_host() - end subroutine d_base_scal + interface + module subroutine d_base_scal(alpha, x) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent (in) :: alpha + end subroutine d_base_scal + end interface ! ! Norms 1, 2 and infinity @@ -2171,69 +1367,39 @@ contains !! \memberof psb_d_base_vect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function d_base_nrm2(n,x) result(res) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - real(psb_dpk_), external :: dnrm2 - - if (x%is_dev()) call x%sync() - res = dnrm2(n,x%v,1) - - end function d_base_nrm2 + interface + module function d_base_nrm2(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_base_nrm2 + end interface ! !> Function base_amax !! \memberof psb_d_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function d_base_amax(n,x) result(res) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res = dzero - !$omp parallel do private(i) reduction(max: res) - do i=1, n - res = max(res,abs(x%v(i))) - end do -#else - res = maxval(abs(x%v(1:n))) -#endif - end function d_base_amax + interface + module function d_base_amax(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_base_amax + end interface ! !> Function base_min !! \memberof psb_d_base_vect_type !! \brief min x(1:n) !! \param n how many entries to consider - function d_base_min(n,x) result(res) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res = HUGE(done) - !$omp parallel do private(i) reduction(min: res) - do i=1, n - res = min(res,abs(x%v(i))) - end do -#else - ! - ! From M&R&C: if the array is of size zero, MINVAL - ! returns the largest positive value - ! - res = minval(x%v(1:n)) -#endif - end function d_base_min + interface + module function d_base_min(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_base_min + end interface ! !> Function base_minquotient_v @@ -2243,21 +1409,14 @@ contains !! \param y The denumerator vector !! \param info return code !! - function d_base_minquotient_v(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - real(psb_dpk_) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - - z = x%minquotient(y%v,info) - - end function d_base_minquotient_v + interface + module function d_base_minquotient_v(x, y, info) result(z) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + end function d_base_minquotient_v + end interface ! !> Function base_minquotient_a2 @@ -2267,55 +1426,27 @@ contains !! \param y The denumerator array !! \param info return code !! - function d_base_minquotient_a2(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: y(:) - real(psb_dpk_) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - real(psb_dpk_) :: temp - - info = 0 - - z = huge(z) - n = min(size(y), size(x%v)) - !$omp parallel do private(i,temp) reduction(min: z) - do i=1, n - if ( y(i) /= dzero ) then - temp = x%v(i)/y(i) - z = min(z,temp) - end if - end do - - end function d_base_minquotient_a2 - - + interface + module function d_base_minquotient_a2(x, y, info) result(z) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + end function d_base_minquotient_a2 + end interface + ! !> Function base_asum !! \memberof psb_d_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function d_base_asum(n,x) result(res) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res=dzero - !$omp parallel do private(i) reduction(+: res) - do i= 1, size(x%v) - res = res + abs(x%v(i)) - end do -#else - res = sum(abs(x%v(1:n))) -#endif - end function d_base_asum - + interface + module function d_base_asum(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function d_base_asum + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -2329,18 +1460,15 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine d_base_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: alpha, beta, y(:) - class(psb_d_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,alpha,x%v,beta,y) - - end subroutine d_base_gthab + interface + module subroutine d_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_base_vect_type) :: x + end subroutine d_base_gthab + end interface + ! ! shortcut alpha=1 beta=0 ! @@ -2350,77 +1478,60 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine d_base_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - real(psb_dpk_) :: y(:) - class(psb_d_base_vect_type) :: x - - if (idx%is_dev()) call idx%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine d_base_gthzv_x - + interface + module subroutine d_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: y(:) + class(psb_d_base_vect_type) :: x + end subroutine d_base_gthzv_x + end interface + ! ! New comm internals impl. ! - subroutine d_base_gthzbuf(i,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - class(psb_d_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),x%combuf(i:)) - - end subroutine d_base_gthzbuf + interface + module subroutine d_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_d_base_vect_type) :: x + end subroutine d_base_gthzbuf + end interface + ! !> Function base_device_wait: !! \memberof psb_d_base_vect_type !! \brief device_wait: base version is a no-op. !! ! - subroutine d_base_device_wait() - implicit none - - end subroutine d_base_device_wait - - function d_base_use_buffer() result(res) - logical :: res - - res = .true. - end function d_base_use_buffer - - subroutine d_base_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%combuf,info) - end subroutine d_base_new_buffer - - subroutine d_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine d_base_new_comid + interface + module subroutine d_base_device_wait() + end subroutine d_base_device_wait + end interface + interface + module function d_base_use_buffer() result(res) + logical :: res + end function d_base_use_buffer + end interface + + interface + module subroutine d_base_new_buffer(n,x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_new_buffer + end interface + + interface + module subroutine d_base_new_comid(n,x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_new_comid + end interface ! ! shortcut alpha=1 beta=0 @@ -2431,18 +1542,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine d_base_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: y(:) - class(psb_d_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,x%v,y) - - end subroutine d_base_gthzv + interface + module subroutine d_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_base_vect_type) :: x + end subroutine d_base_gthzv + end interface ! ! Scatter: @@ -2457,56 +1564,35 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine d_base_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: beta, x(:) - class(psb_d_base_vect_type) :: y - - if (y%is_dev()) call y%sync() - call psi_sct(n,idx,x,beta,y%v) - call y%set_host() - - end subroutine d_base_sctb - - subroutine d_base_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_dpk_) :: beta, x(:) - class(psb_d_base_vect_type) :: y - - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),x,beta) - call y%set_host() - - end subroutine d_base_sctb_x - - subroutine d_base_sctb_buf(i,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_dpk_) :: beta - class(psb_d_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),y%combuf(i:),beta) - call y%set_host() - - end subroutine d_base_sctb_buf - + interface + module subroutine d_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_base_vect_type) :: y + end subroutine d_base_sctb + end interface + + interface + module subroutine d_base_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_base_vect_type) :: y + end subroutine d_base_sctb_x + end interface + + interface + module subroutine d_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta + class(psb_d_base_vect_type) :: y + end subroutine d_base_sctb_buf + end interface + ! !> Function base_mask_a !! \memberof psb_d_base_vect_type @@ -2520,56 +1606,16 @@ contains !! \param t logical resulting from an and operation on all the tests !! \param info return code ! - subroutine d_base_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(:) - class(psb_d_base_vect_type), intent(inout) :: m - integer(psb_ipk_), intent(out) :: info - logical, intent(out) :: t - integer(psb_ipk_) :: i, n - - if (m%is_dev()) call m%sync() - t = .true. - - n = size(x) - do i = 1, n, 1 - if (c(i).eq.2_psb_dpk_) then - if ( x(i) > dzero ) then - m%v(i) = 0_psb_dpk_ - else - m%v(i) = 1_psb_dpk_ - t = .false. - end if - elseif (c(i).eq.1_psb_dpk_) then - if ( x(i) >= dzero ) then - m%v(i) = 0_psb_dpk_ - else - m%v(i) = 1_psb_dpk_ - t = .false. - end if - elseif (c(i).eq.-1_psb_dpk_) then - if ( x(i) <= dzero ) then - m%v(i) = 0_psb_dpk_ - else - m%v(i) = 1_psb_dpk_ - t = .false. - end if - elseif (c(i).eq.-2_psb_dpk_) then - if ( x(i) < dzero ) then - m%v(i) = 0_psb_dpk_ - else - m%v(i) = 1_psb_dpk_ - t = .false. - end if - else - m%v(i) = 0_psb_dpk_ - end if - end do - info = 0 - - end subroutine d_base_mask_a + interface + module subroutine d_base_mask_a(c,x,m,t,info) + real(psb_dpk_), intent(inout) :: c(:) + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + end subroutine d_base_mask_a + end interface + ! !> Function base_mask_v !! \memberof psb_d_base_vect_type @@ -2583,22 +1629,15 @@ contains !! \param t logical resulting from an and operation on all the tests !! \param info return code ! - subroutine d_base_mask_v(c,x,m,t,info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: c - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: m - integer(psb_ipk_), intent(out) :: info - logical, intent(out) :: t - - info = 0 - if (x%is_dev()) call x%sync() - if (c%is_dev()) call c%sync() - - call m%mask(x%v,c%v,t,info) - end subroutine d_base_mask_v - + interface + module subroutine d_base_mask_v(c,x,m,t,info) + class(psb_d_base_vect_type), intent(inout) :: c + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + end subroutine d_base_mask_v + end interface ! !> Function _base_addconst_a2 @@ -2609,28 +1648,15 @@ contains !! \param b The added term !! \param info return code ! - subroutine d_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() -#if defined(PSB_OPENMP) - n = size(x) - !$omp parallel do private(i) - do i = 1, n - z%v(i) = x(i) + b - end do -#else - z%v = x + b -#endif - info = 0 - - end subroutine d_base_addconst_a2 + interface + module subroutine d_base_addconst_a2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_addconst_a2 + end interface + ! !> Function _base_addconst_v2 !! \memberof psb_d_base_vect_type @@ -2640,24 +1666,53 @@ contains !! \param b The added term !! \param info return code ! - subroutine d_base_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: b - class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%addconst(x%v,b,info) - end subroutine d_base_addconst_v2 + interface + module subroutine d_base_addconst_v2(x,b,z,info) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: b + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_addconst_v2 + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + real(psb_dpk_) :: x(:) + type(psb_d_base_vect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_d_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const + end module psb_d_base_vect_mod module psb_d_base_multivect_mod - use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_d_base_vect_mod @@ -2672,8 +1727,6 @@ module psb_d_base_multivect_mod !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private - public :: psb_d_base_multivect, psb_d_base_multivect_type type psb_d_base_multivect_type !> Values. @@ -2819,43 +1872,13 @@ module psb_d_base_multivect_mod generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_d_base_multivect_type + public :: psb_d_base_multivect, psb_d_base_multivect_type + interface psb_d_base_multivect module procedure constructor, size_const end interface psb_d_base_multivect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - real(psb_dpk_) :: x(:,:) - type(psb_d_base_multivect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),& - & size(x,dim=2,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_d_base_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(m,n,info) - - end function size_const + private ! ! Build from a sample @@ -2866,21 +1889,14 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine d_base_mlv_bld_x(x,this) - use psb_realloc_mod - real(psb_dpk_), intent(in) :: this(:,:) - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - - call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') - return - end if - x%v(:,:) = this(:,:) - - end subroutine d_base_mlv_bld_x - + interface + module subroutine d_base_mlv_bld_x(x,this) + real(psb_dpk_), intent(in) :: this(:,:) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + end subroutine d_base_mlv_bld_x + end interface + ! ! Create with size, but no initialization ! @@ -2890,18 +1906,15 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_mlv_bld_n(x,m,n,scratch) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: m,n - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch=scratch) - - end subroutine d_base_mlv_bld_n - + interface + module subroutine d_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + end subroutine d_base_mlv_bld_n + end interface + !> Function base_mlv_all: !! \memberof psb_d_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -2909,21 +1922,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine d_base_mlv_all(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_d_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(m,n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine d_base_mlv_all + interface + module subroutine d_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_all + end interface !> Function base_mlv_mold: !! \memberof psb_d_base_multivect_type @@ -2931,34 +1936,20 @@ contains !! \param y returned variable !! \param info return code !! - subroutine d_base_mlv_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - class(psb_d_base_multivect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_d_base_multivect_type :: y, stat=info) + interface + module subroutine d_base_mlv_mold(x, y, info) + class(psb_d_base_multivect_type), intent(in) :: x + class(psb_d_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_mold + end interface - end subroutine d_base_mlv_mold - - subroutine d_base_mlv_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%sync() - x%v(:,:) = dzero - call x%set_host() - call x%set_upd() - end if - - end subroutine d_base_mlv_reinit + interface + module subroutine d_base_mlv_reinit(x, info) + class(psb_d_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -2987,129 +1978,15 @@ contains !! \param info return code !! ! - subroutine d_base_mlv_ins(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - nc = size(x%v,2) - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_realloc(isz,nc,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k,:) = val(i,:) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_mlv_vect_ins') - return - end if - - end subroutine d_base_mlv_ins + interface + module subroutine d_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_ins + end interface ! !> Function base_mlv_zero @@ -3117,16 +1994,11 @@ contains !! \brief Zero out contents !! ! - subroutine d_base_mlv_zero(x) - use psi_serial_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) x%v=dzero - call x%set_host() - - end subroutine d_base_mlv_zero - + interface + module subroutine d_base_mlv_zero(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_zero + end interface ! ! Assembly. @@ -3141,81 +2013,15 @@ contains !! \param info return code !! ! - - subroutine d_base_mlv_asb(m,n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - real(psb_dpk_), allocatable :: vv(:,:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(m,n,vv,info) - vv(:,:) = dzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i),:) = x%v(i,:) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (any(vv(x%iv(i),:).ne.dzero)) then - info = psb_err_duplicate_coo - call psb_errpush(info,'mvect-asb') - return - else - vv(x%iv(i),:) = x%v(i,:) - end if - end do - case default - write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: @@ -3225,118 +2031,106 @@ contains !! \param info return code !! ! - subroutine d_base_mlv_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - - end subroutine d_base_mlv_free - - function d_base_mlv_get_ncfs(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function d_base_mlv_get_ncfs - - function d_base_mlv_get_dupl(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function d_base_mlv_get_dupl - - function d_base_mlv_get_state(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function d_base_mlv_get_state - - function d_base_mlv_is_null(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function d_base_mlv_is_null - - function d_base_mlv_is_bld(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function d_base_mlv_is_bld - - function d_base_mlv_is_upd(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function d_base_mlv_is_upd - - function d_base_mlv_is_asb(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function d_base_mlv_is_asb - - subroutine d_base_mlv_set_ncfs(n,x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine d_base_mlv_set_ncfs - - subroutine d_base_mlv_set_dupl(n,x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine d_base_mlv_set_dupl - - subroutine d_base_mlv_set_state(n,x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine d_base_mlv_set_state - - subroutine d_base_mlv_set_null(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine d_base_mlv_set_null - - subroutine d_base_mlv_set_bld(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine d_base_mlv_set_bld - - subroutine d_base_mlv_set_upd(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine d_base_mlv_set_upd - - subroutine d_base_mlv_set_asb(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine d_base_mlv_set_asb - + interface + module subroutine d_base_mlv_free(x, info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_free + end interface + + interface + module function d_base_mlv_get_ncfs(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_mlv_get_ncfs + end interface + + interface + module function d_base_mlv_get_dupl(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_mlv_get_dupl + end interface + + interface + module function d_base_mlv_get_state(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_mlv_get_state + end interface + + interface + module function d_base_mlv_is_null(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + end function d_base_mlv_is_null + end interface + + interface + module function d_base_mlv_is_bld(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + end function d_base_mlv_is_bld + end interface + + interface + module function d_base_mlv_is_upd(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + end function d_base_mlv_is_upd + end interface + + interface + module function d_base_mlv_is_asb(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + end function d_base_mlv_is_asb + end interface + + interface + module subroutine d_base_mlv_set_ncfs(n,x) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine d_base_mlv_set_ncfs + end interface + + interface + module subroutine d_base_mlv_set_dupl(n,x) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine d_base_mlv_set_dupl + end interface + + interface + module subroutine d_base_mlv_set_state(n,x) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine d_base_mlv_set_state + end interface + + interface + module subroutine d_base_mlv_set_null(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_null + end interface + + interface + module subroutine d_base_mlv_set_bld(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_bld + end interface + + interface + module subroutine d_base_mlv_set_upd(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_upd + end interface + + interface + module subroutine d_base_mlv_set_asb(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -3348,11 +2142,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine d_base_mlv_sync(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - end subroutine d_base_mlv_sync + interface + module subroutine d_base_mlv_sync(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_sync + end interface ! !> Function base_mlv_set_host: @@ -3360,11 +2154,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine d_base_mlv_set_host(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - end subroutine d_base_mlv_set_host + interface + module subroutine d_base_mlv_set_host(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_host + end interface ! !> Function base_mlv_set_dev: @@ -3372,11 +2166,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine d_base_mlv_set_dev(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - end subroutine d_base_mlv_set_dev + interface + module subroutine d_base_mlv_set_dev(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_dev + end interface ! !> Function base_mlv_set_sync: @@ -3384,11 +2178,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine d_base_mlv_set_sync(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - end subroutine d_base_mlv_set_sync + interface + module subroutine d_base_mlv_set_sync(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3396,13 +2190,12 @@ contains !! \brief Is vector on external device . !! ! - function d_base_mlv_is_dev(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - logical :: res - - res = .false. - end function d_base_mlv_is_dev + interface + module function d_base_mlv_is_dev(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + end function d_base_mlv_is_dev + end interface ! !> Function base_mlv_is_host @@ -3410,13 +2203,12 @@ contains !! \brief Is vector on standard memory . !! ! - function d_base_mlv_is_host(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function d_base_mlv_is_host + interface + module function d_base_mlv_is_host(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + end function d_base_mlv_is_host + end interface ! !> Function base_mlv_is_sync @@ -3424,35 +2216,25 @@ contains !! \brief Is vector on sync . !! ! - function d_base_mlv_is_sync(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function d_base_mlv_is_sync + interface + module function d_base_mlv_is_sync(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + end function d_base_mlv_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine d_base_mlv_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - class(psb_d_base_multivect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine d_base_mlv_cpy - + interface + module subroutine d_base_mlv_cpy(x, y) + class(psb_d_base_multivect_type), intent(in) :: x + class(psb_d_base_multivect_type), intent(out) :: y + end subroutine d_base_mlv_cpy + end interface - ! ! Size info. ! ! @@ -3461,25 +2243,19 @@ contains !! \brief Number of entries !! ! - function d_base_mlv_get_nrows(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function d_base_mlv_get_nrows + interface + module function d_base_mlv_get_nrows(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_mlv_get_nrows + end interface - function d_base_mlv_get_ncols(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,2) - - end function d_base_mlv_get_ncols + interface + module function d_base_mlv_get_ncols(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function d_base_mlv_get_ncols + end interface ! !> Function base_mlv_get_sizeof @@ -3487,15 +2263,12 @@ contains !! \brief Size in bytesa !! ! - function d_base_mlv_sizeof(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() * x%get_ncols() - - end function d_base_mlv_sizeof + interface + module function d_base_mlv_sizeof(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function d_base_mlv_sizeof + end interface ! !> Function base_mlv_get_fmt @@ -3503,12 +2276,11 @@ contains !! \brief Format !! ! - function d_base_mlv_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function d_base_mlv_get_fmt - + interface + module function d_base_mlv_get_fmt() result(res) + character(len=5) :: res + end function d_base_mlv_get_fmt + end interface ! ! @@ -3518,22 +2290,12 @@ contains !! \brief Extract a copy of the contents !! ! - function d_base_mlv_get_vect(x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - real(psb_dpk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info,m,n - m = x%get_nrows() - n = x%get_ncols() - if (.not.allocated(x%v)) return - call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') - return - end if - res(1:m,1:n) = x%v(1:m,1:n) - end function d_base_mlv_get_vect + interface + module function d_base_mlv_get_vect(x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:,:) + end function d_base_mlv_get_vect + end interface ! ! Reset all values @@ -3544,39 +2306,25 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine d_base_mlv_set_scal(x,val) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val - - integer(psb_ipk_) :: info - x%v = val - - end subroutine d_base_mlv_set_scal - + interface + module subroutine d_base_mlv_set_scal(x,val) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + end subroutine d_base_mlv_set_scal + end interface + ! !> Function base_mlv_set_vect !! \memberof psb_d_base_multivect_type !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine d_base_mlv_set_vect(x,val) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_) :: nr, nc - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - nr = min(size(x%v,1),size(val,1)) - nc = min(size(x%v,2),size(val,2)) - - x%v(1:nr,1:nc) = val(1:nr,1:nc) - else - x%v = val - end if - - end subroutine d_base_mlv_set_vect + interface + module subroutine d_base_mlv_set_vect(x,val) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:,:) + end subroutine d_base_mlv_set_vect + end interface ! ! Dot products @@ -3588,36 +2336,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_mlv_vect) to be multiplied by !! - function d_base_mlv_dot_v(n,x,y) result(res) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - real(psb_dpk_), external :: ddot - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - res = dzero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_d_base_mlv_vect (or its class does not care). - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_d_base_multivect_type) - if (y%is_dev()) call y%sync() - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = ddot(n,x%v(:,j),1,y%v(:,j),1) - end do - class default - res = y%dot(n,x%v) - end select - - end function d_base_mlv_dot_v + interface + module function d_base_mlv_dot_v(n,x,y) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function d_base_mlv_dot_v + end interface ! ! Base workhorse is good old BLAS1 @@ -3629,23 +2354,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function d_base_mlv_dot_a(n,x,y) result(res) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: y(:,:) - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - real(psb_dpk_), external :: ddot - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = ddot(n,x%v(:,j),1,y(:,j),1) - end do - - end function d_base_mlv_dot_a + interface + module function d_base_mlv_dot_a(n,x,y) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function d_base_mlv_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3661,30 +2377,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine d_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_d_base_multivect_type), intent(inout) :: x - class(psb_d_base_multivect_type), intent(inout) :: y - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - - if (present(n)) then - nc = n - else - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - end if - select type(xx => x) - type is (psb_d_base_multivect_type) - call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default - call y%axpby(m,alpha,x%v,beta,info,n=n) - end select - - end subroutine d_base_mlv_axpby_v + interface + module subroutine d_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine d_base_mlv_axpby_v + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3699,26 +2401,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine d_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - real(psb_dpk_), intent(in) :: x(:,:) - class(psb_d_base_multivect_type), intent(inout) :: y - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - if (present(n)) then - nc = n - else - nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) - end if - - call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - - end subroutine d_base_mlv_axpby_a - + interface + module subroutine d_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:,:) + class(psb_d_base_multivect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine d_base_mlv_axpby_a + end interface ! ! Multiple variants of two operations: @@ -3735,31 +2427,21 @@ contains !! \param x The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine d_base_mlv_mlt_mv(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - class(psb_d_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine d_base_mlv_mlt_mv + interface + module subroutine d_base_mlv_mlt_mv(x, y, info) + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_mlt_mv + end interface - subroutine d_base_mlv_mlt_mv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine d_base_mlv_mlt_mv_v + interface + module subroutine d_base_mlv_mlt_mv_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_mlt_mv_v + end interface ! !> Function base_mlv_mlt_ar1 @@ -3768,22 +2450,14 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine d_base_mlv_mlt_ar1(x, y, info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: x(:) - class(psb_d_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n - y%v(i,:) = y%v(i,:)*x(i) - end do - - end subroutine d_base_mlv_mlt_ar1 - + interface + module subroutine d_base_mlv_mlt_ar1(x, y, info) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_mlt_ar1 + end interface + ! !> Function base_mlv_mlt_ar2 !! \memberof psb_d_base_multivect_type @@ -3791,21 +2465,13 @@ contains !! \param x(:,:) The array to be multiplied by !! \param info return code !! - subroutine d_base_mlv_mlt_ar2(x, y, info) - use psi_serial_mod - implicit none - real(psb_dpk_), intent(in) :: x(:,:) - class(psb_d_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr,nc - - info = 0 - nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) - nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) - y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - - end subroutine d_base_mlv_mlt_ar2 - + interface + module subroutine d_base_mlv_mlt_ar2(x, y, info) + real(psb_dpk_), intent(in) :: x(:,:) + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_mlt_ar2 + end interface ! !> Function base_mlv_mlt_a_2 @@ -3818,54 +2484,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine d_base_mlv_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_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr, nc - - info = 0 - nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == dzero) then - if (beta == done) then - return - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - end if - else - if (alpha == done) then - if (beta == dzero) then - z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == done) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else if (alpha == -done) then - if (beta == dzero) then - z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == done) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else - if (beta == dzero) then - z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == done) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - end if - end if - end if - end subroutine d_base_mlv_mlt_a_2 - + interface + module subroutine d_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_mlt_a_2 + end interface + ! !> Function base_mlv_mlt_v_2 !! \memberof psb_d_base_multivect_type @@ -3877,41 +2505,18 @@ contains !! \param y The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine d_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - real(psb_dpk_), intent(in) :: alpha,beta - class(psb_d_base_multivect_type), intent(inout) :: x - class(psb_d_base_multivect_type), intent(inout) :: y - class(psb_d_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - if (z%is_dev()) call z%sync() - if (.not.psb_d_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - end if - end subroutine d_base_mlv_mlt_v_2 + interface + module subroutine d_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_dpk_), intent(in) :: alpha,beta + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + class(psb_d_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine d_base_mlv_mlt_v_2 + end interface !!$ !!$ subroutine d_base_mlv_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_base_multivect_type), intent(inout) :: y @@ -3926,8 +2531,6 @@ contains !!$ end subroutine d_base_mlv_mlt_av !!$ !!$ subroutine d_base_mlv_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_base_multivect_type), intent(inout) :: x @@ -3950,17 +2553,13 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine d_base_mlv_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - real(psb_dpk_), intent (in) :: alpha - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) x%v = alpha*x%v - - end subroutine d_base_mlv_scal - + interface + module subroutine d_base_mlv_scal(alpha, x) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent (in) :: alpha + end subroutine d_base_mlv_scal + end interface + ! ! Norms 1, 2 and infinity ! @@ -3968,64 +2567,40 @@ contains !! \memberof psb_d_base_multivect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function d_base_mlv_nrm2(n,x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - real(psb_dpk_), external :: dnrm2 - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = dnrm2(n,x%v(:,j),1) - end do - - end function d_base_mlv_nrm2 + interface + module function d_base_mlv_nrm2(n,x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function d_base_mlv_nrm2 + end interface ! !> Function base_mlv_amax !! \memberof psb_d_base_multivect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function d_base_mlv_amax(n,x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = maxval(abs(x%v(1:n,j))) - end do - - end function d_base_mlv_amax - + interface + module function d_base_mlv_amax(n,x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function d_base_mlv_amax + end interface + ! !> Function base_mlv_asum !! \memberof psb_d_base_multivect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function d_base_mlv_asum(n,x) result(res) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = sum(abs(x%v(1:n,j))) - end do - - end function d_base_mlv_asum + interface + module function d_base_mlv_asum(n,x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function d_base_mlv_asum + end interface + ! ! Overwrite with absolute value ! @@ -4034,96 +2609,63 @@ contains !! \memberof psb_d_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine d_base_mlv_absval1(x) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v = abs(x%v) - call x%set_host() - end if - - end subroutine d_base_mlv_absval1 - - subroutine d_base_mlv_absval2(x,y) - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - class(psb_d_base_multivect_type), intent(inout) :: y - integer(psb_ipk_) :: info - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) then - call y%axpby(min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) - call y%absval() - end if - - end subroutine d_base_mlv_absval2 - - - function d_base_mlv_use_buffer() result(res) - implicit none - logical :: res - - res = .true. - end function d_base_mlv_use_buffer - - subroutine d_base_mlv_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: nc - nc = x%get_ncols() - call psb_realloc(n*nc,x%combuf,info) - end subroutine d_base_mlv_new_buffer - - subroutine d_base_mlv_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine d_base_mlv_new_comid - - - subroutine d_base_mlv_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine d_base_mlv_maybe_free_buffer - - subroutine d_base_mlv_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine d_base_mlv_free_buffer - - subroutine d_base_mlv_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_d_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine d_base_mlv_free_comid + interface + module subroutine d_base_mlv_absval1(x) + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_absval1 + end interface + + interface + module subroutine d_base_mlv_absval2(x,y) + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + end subroutine d_base_mlv_absval2 + end interface + + + interface + module function d_base_mlv_use_buffer() result(res) + logical :: res + end function d_base_mlv_use_buffer + end interface + + interface + module subroutine d_base_mlv_new_buffer(n,x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_new_buffer + end interface + + interface + module subroutine d_base_mlv_new_comid(n,x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_new_comid + end interface + + interface + module subroutine d_base_mlv_maybe_free_buffer(x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_maybe_free_buffer + end interface + + interface + module subroutine d_base_mlv_free_buffer(x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_free_buffer + end interface + interface + module subroutine d_base_mlv_free_comid(x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_mlv_free_comid + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -4137,23 +2679,14 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine d_base_mlv_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: alpha, beta, y(:) - class(psb_d_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - call psi_gth(n,nc,idx,alpha,x%v,beta,y) - - end subroutine d_base_mlv_gthab + interface + module subroutine d_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_base_multivect_type) :: x + end subroutine d_base_mlv_gthab + end interface ! ! shortcut alpha=1 beta=0 ! @@ -4163,19 +2696,15 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine d_base_mlv_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_dpk_) :: y(:) - class(psb_d_base_multivect_type) :: x - - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine d_base_mlv_gthzv_x + interface + module subroutine d_base_mlv_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_base_multivect_type) :: x + end subroutine d_base_mlv_gthzv_x + end interface ! ! shortcut alpha=1 beta=0 @@ -4186,24 +2715,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine d_base_mlv_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: y(:) - class(psb_d_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine d_base_mlv_gthzv + interface + module subroutine d_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_base_multivect_type) :: x + end subroutine d_base_mlv_gthzv + end interface ! ! shortcut alpha=1 beta=0 ! @@ -4213,48 +2732,27 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine d_base_mlv_gthzm(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: y(:,:) - class(psb_d_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine d_base_mlv_gthzm + interface + module subroutine d_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:,:) + class(psb_d_base_multivect_type) :: x + end subroutine d_base_mlv_gthzm + end interface ! ! New comm internals impl. ! - subroutine d_base_mlv_gthzbuf(i,ixb,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, ixb - class(psb_i_base_vect_type) :: idx - class(psb_d_base_multivect_type) :: x - integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - nc = x%get_ncols() - call x%gth(n,idx%v(i:),x%combuf(ixb:)) - - end subroutine d_base_mlv_gthzbuf - + interface + module subroutine d_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_d_base_multivect_type) :: x + end subroutine d_base_mlv_gthzbuf + end interface + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -4268,72 +2766,43 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine d_base_mlv_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: beta, x(:) - class(psb_d_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = psb_size(y%v,2_psb_ipk_) - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine d_base_mlv_sctb - - subroutine d_base_mlv_sctbr2(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_dpk_) :: beta, x(:,:) - class(psb_d_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = y%get_ncols() - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine d_base_mlv_sctbr2 - - subroutine d_base_mlv_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real( psb_dpk_) :: beta, x(:) - class(psb_d_base_multivect_type) :: y - - call y%sct(n,idx%v(i:),x,beta) - - end subroutine d_base_mlv_sctb_x - - subroutine d_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, iyb - class(psb_i_base_vect_type) :: idx - real(psb_dpk_) :: beta - class(psb_d_base_multivect_type) :: y - integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - nc = y%get_ncols() - call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) - call y%set_host() - - end subroutine d_base_mlv_sctb_buf + interface + module subroutine d_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_base_multivect_type) :: y + end subroutine d_base_mlv_sctb + end interface + + interface + module subroutine d_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:,:) + class(psb_d_base_multivect_type) :: y + end subroutine d_base_mlv_sctbr2 + end interface + + interface + module subroutine d_base_mlv_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_base_multivect_type) :: y + end subroutine d_base_mlv_sctb_x + end interface + + interface + module subroutine d_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta + class(psb_d_base_multivect_type) :: y + end subroutine d_base_mlv_sctb_buf + end interface ! !> Function base_device_wait: @@ -4341,9 +2810,43 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine d_base_mlv_device_wait() - implicit none + interface + module subroutine d_base_mlv_device_wait() + end subroutine d_base_mlv_device_wait + end interface + +contains + + ! + ! Constructors. + ! - end subroutine d_base_mlv_device_wait + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + real(psb_dpk_) :: x(:,:) + type(psb_d_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_d_base_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(m,n,info) + + end function size_const end module psb_d_base_multivect_mod diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index c816e835f..bd451e21f 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -168,7 +168,10 @@ module psb_d_vect_mod end type psb_d_vect_type - public :: psb_d_vect + public :: psb_d_vect, psb_d_vect_type,& + & psb_d_set_vect_default, psb_d_get_vect_default, & + & psb_d_clear_vect_default, psb_d_base_vect_type + private :: constructor, size_const interface psb_d_vect module procedure constructor, size_const @@ -195,180 +198,758 @@ module psb_d_vect_mod class(psb_d_base_vect_type), allocatable, target,& & save, private :: psb_d_base_vect_default - interface psb_set_vect_default - module procedure psb_d_set_vect_default - end interface psb_set_vect_default - interface psb_get_vect_default - module procedure psb_d_get_vect_default - end interface psb_get_vect_default + interface + module function d_vect_get_dupl(x) result(res) + 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 + 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 + 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 @@ -379,7 +960,6 @@ contains 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 @@ -388,7 +968,6 @@ contains 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) @@ -397,7 +976,6 @@ contains 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 @@ -408,150 +986,6 @@ contains 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,980 +1007,6 @@ 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 y%v%div(x%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 y%v%div(x%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(done) - 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 @@ -1556,7 +1016,6 @@ module psb_d_multivect_mod use psb_const_mod use psb_i_vect_mod - !private type psb_d_multivect_type @@ -1619,422 +1078,231 @@ module psb_d_multivect_mod end type psb_d_multivect_type public :: psb_d_multivect, psb_d_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default, & - & psb_d_base_multivect_type + & psb_d_set_multivect_default, psb_d_get_base_multivect_default, & + & psb_d_clear_multivect_default, psb_d_base_multivect_type - private interface psb_d_multivect module procedure constructor, size_const end interface psb_d_multivect + private + 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 - + 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 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 - 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 + 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 + integer(psb_ipk_) :: info + end subroutine d_mvect_cnv + end interface -!!$ function d_mvect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ module function d_mvect_dot_v(n,x,y) result(res) !!$ class(psb_d_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res @@ -2046,7 +1314,6 @@ contains !!$ end function d_mvect_dot_v !!$ !!$ 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 @@ -2058,9 +1325,7 @@ contains !!$ !!$ end function d_mvect_dot_a !!$ -!!$ subroutine d_mvect_axpby_v(m,alpha, x, beta, y, info) -!!$ use psi_serial_mod -!!$ implicit none +!!$ module subroutine d_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: y @@ -2076,8 +1341,6 @@ contains !!$ end subroutine d_mvect_axpby_v !!$ !!$ 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 @@ -2091,8 +1354,6 @@ contains !!$ !!$ !!$ 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 @@ -2105,8 +1366,6 @@ contains !!$ end subroutine d_mvect_mlt_v !!$ !!$ 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 @@ -2121,8 +1380,6 @@ contains !!$ !!$ !!$ 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(:) @@ -2137,8 +1394,6 @@ contains !!$ end subroutine d_mvect_mlt_a_2 !!$ !!$ 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 @@ -2156,8 +1411,6 @@ contains !!$ end subroutine d_mvect_mlt_v_2 !!$ !!$ 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 @@ -2172,8 +1425,6 @@ contains !!$ end subroutine d_mvect_mlt_av !!$ !!$ 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 @@ -2189,8 +1440,6 @@ contains !!$ end subroutine d_mvect_mlt_va !!$ !!$ 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 !!$ @@ -2200,7 +1449,6 @@ contains !!$ !!$ !!$ 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 @@ -2214,7 +1462,6 @@ contains !!$ end function d_mvect_nrm2 !!$ !!$ 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 @@ -2228,7 +1475,6 @@ contains !!$ end function d_mvect_amax !!$ !!$ 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 @@ -2241,4 +1487,65 @@ contains !!$ !!$ end function d_mvect_asum +contains + + subroutine psb_d_set_multivect_default(v) + 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) +!!$ 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) + 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 + + 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 + + + subroutine psb_d_clear_multivect_default() + + if (allocated(psb_d_base_multivect_default)) then + deallocate(psb_d_base_multivect_default) + end if + + end subroutine psb_d_clear_multivect_default + end module psb_d_multivect_mod diff --git a/base/modules/serial/psb_i2_base_vect_mod.F90 b/base/modules/serial/psb_i2_base_vect_mod.F90 index b90db989b..61a4b14e0 100644 --- a/base/modules/serial/psb_i2_base_vect_mod.F90 +++ b/base/modules/serial/psb_i2_base_vect_mod.F90 @@ -178,45 +178,12 @@ module psb_i2_base_vect_mod end type psb_i2_base_vect_type - public :: psb_i2_base_vect + public :: psb_i2_base_vect, psb_i2_base_vect_type private :: constructor, size_const interface psb_i2_base_vect module procedure constructor, size_const end interface psb_i2_base_vect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - integer(psb_i2pk_) :: x(:) - type(psb_i2_base_vect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(n) result(this) - integer(psb_ipk_), intent(in) :: n - type(psb_i2_base_vect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(n,info) - - end function size_const - ! ! Build from a sample ! @@ -226,36 +193,13 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine i2_base_bld_x(x,this,scratch) - use psb_realloc_mod - implicit none - integer(psb_i2pk_), intent(in) :: this(:) - class(psb_i2_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - integer(psb_ipk_) :: i - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(size(this),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') - return - end if -#if defined (PSB_OPENMP) - !$omp parallel do private(i) - do i = 1, size(this) - x%v(i) = this(i) - end do -#else - x%v(:) = this(:) -#endif - end subroutine i2_base_bld_x + interface + module subroutine i2_base_bld_x(x,this,scratch) + integer(psb_i2pk_), intent(in) :: this(:) + class(psb_i2_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine i2_base_bld_x + end interface ! ! Create with size, but no initialization @@ -266,50 +210,26 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i2_base_bld_mn(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_i2_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine i2_base_bld_mn - + interface + module subroutine i2_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine i2_base_bld_mn + end interface + !> Function bld_en: !! \memberof psb_i2_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i2_base_bld_en(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_i2_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine i2_base_bld_en + interface + module subroutine i2_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine i2_base_bld_en + end interface !> Function base_all: !! \memberof psb_i2_base_vect_type @@ -318,21 +238,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine i2_base_all(n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_i2_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine i2_base_all + interface + module subroutine i2_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_all + end interface !> Function base_mold: !! \memberof psb_i2_base_vect_type @@ -340,42 +252,21 @@ contains !! \param y returned variable !! \param info return code !! - subroutine i2_base_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - class(psb_i2_base_vect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_i2_base_vect_type :: y, stat=info) - - end subroutine i2_base_mold - - subroutine i2_base_reinit(x, info,clear) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - logical :: clear_ - - info = 0 - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - if (clear_) x%v(:) = i2zero - call x%set_host() - call x%set_upd() - end if + interface + module subroutine i2_base_mold(x, y, info) + class(psb_i2_base_vect_type), intent(in) :: x + class(psb_i2_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mold + end interface - end subroutine i2_base_reinit + interface + module subroutine i2_base_reinit(x, info,clear) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine i2_base_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -404,152 +295,27 @@ contains !! \param info return code !! ! - subroutine i2_base_ins_a(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_i2pk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine i2_base_ins_a - - subroutine i2_base_ins_v(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - class(psb_i_base_vect_type), intent(inout) :: irl - class(psb_i2_base_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: isz - - info = 0 - if (psb_errstatus_fatal()) return - - if (irl%is_dev()) call irl%sync() - if (val%is_dev()) call val%sync() - if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,maxr,info) - - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine i2_base_ins_v + interface + module subroutine i2_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_ins_a + end interface + + + interface + module subroutine i2_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_i2_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_ins_v + end interface + ! @@ -558,18 +324,12 @@ contains !! \brief Zero out contents !! ! - subroutine i2_base_zero(x) - use psi_serial_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x + interface + module subroutine i2_base_zero(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_zero + end interface - if (allocated(x%v)) then - !$omp workshare - x%v(:)=i2zero - !$omp end workshare - end if - call x%set_host() - end subroutine i2_base_zero ! @@ -586,74 +346,15 @@ contains !! ! - subroutine i2_base_asb_m(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_i2pk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(n,vv,info) - vv(:) = i2zero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (vv(x%iv(i)).ne. i2zero) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine i2_base_asb_m + interface + module subroutine i2_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine i2_base_asb_m + end interface + ! ! Assembly. @@ -669,74 +370,15 @@ contains !! ! - subroutine i2_base_asb_e(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_i2pk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') - if (x%is_bld()) then - call psb_realloc(n,vv,info) - vv(:) = i2zero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne. i2zero) then - call psb_errpush(psb_err_duplicate_coo,'vect_asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine i2_base_asb_e + interface + module subroutine i2_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine i2_base_asb_e + end interface + ! !> Function base_free: @@ -746,22 +388,13 @@ contains !! \param info return code !! ! - subroutine i2_base_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i2_base_free(x, info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_free + end interface - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - call x%set_null() - end subroutine i2_base_free ! !> Function base_free_buffer: @@ -771,15 +404,13 @@ contains !! \param info return code !! ! - subroutine i2_base_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i2_base_free_buffer(x,info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_free_buffer + end interface - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine i2_base_free_buffer ! !> Function base_maybe_free_buffer: @@ -792,17 +423,13 @@ contains !! \param info return code !! ! - subroutine i2_base_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i2_base_maybe_free_buffer(x,info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_maybe_free_buffer + end interface - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine i2_base_maybe_free_buffer ! !> Function base_free_comid: @@ -812,113 +439,107 @@ contains !! \param info return code !! ! - subroutine i2_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine i2_base_free_comid - - function i2_base_get_ncfs(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function i2_base_get_ncfs - - function i2_base_get_dupl(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function i2_base_get_dupl - - function i2_base_get_state(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function i2_base_get_state - - function i2_base_is_null(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function i2_base_is_null - - function i2_base_is_bld(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function i2_base_is_bld - - function i2_base_is_upd(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function i2_base_is_upd - - function i2_base_is_asb(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function i2_base_is_asb - - subroutine i2_base_set_ncfs(n,x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine i2_base_set_ncfs - - subroutine i2_base_set_dupl(n,x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine i2_base_set_dupl - - subroutine i2_base_set_state(n,x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine i2_base_set_state - - subroutine i2_base_set_null(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine i2_base_set_null - - subroutine i2_base_set_bld(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine i2_base_set_bld - - subroutine i2_base_set_upd(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine i2_base_set_upd - - subroutine i2_base_set_asb(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine i2_base_set_asb + interface + module subroutine i2_base_free_comid(x,info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_free_comid + end interface + + + interface + module function i2_base_get_ncfs(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_get_ncfs + end interface + + interface + module function i2_base_get_dupl(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_get_dupl + end interface + + interface + module function i2_base_get_state(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_get_state + end interface + + interface + module function i2_base_is_null(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + end function i2_base_is_null + end interface + + interface + module function i2_base_is_bld(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + end function i2_base_is_bld + end interface + + interface + module function i2_base_is_upd(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + end function i2_base_is_upd + end interface + + interface + module function i2_base_is_asb(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + end function i2_base_is_asb + end interface + + interface + module subroutine i2_base_set_ncfs(n,x) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i2_base_set_ncfs + end interface + + interface + module subroutine i2_base_set_dupl(n,x) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i2_base_set_dupl + end interface + + interface + module subroutine i2_base_set_state(n,x) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i2_base_set_state + end interface + + interface + module subroutine i2_base_set_null(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_set_null + end interface + + interface + module subroutine i2_base_set_bld(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_set_bld + end interface + + interface + module subroutine i2_base_set_upd(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_set_upd + end interface + + interface + module subroutine i2_base_set_asb(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -930,11 +551,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine i2_base_sync(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - end subroutine i2_base_sync + interface + module subroutine i2_base_sync(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_sync + end interface ! !> Function base_set_host: @@ -942,11 +563,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine i2_base_set_host(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - end subroutine i2_base_set_host + interface + module subroutine i2_base_set_host(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_set_host + end interface ! !> Function base_set_dev: @@ -954,11 +575,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine i2_base_set_dev(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - end subroutine i2_base_set_dev + interface + module subroutine i2_base_set_dev(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_set_dev + end interface ! !> Function base_set_sync: @@ -966,11 +587,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine i2_base_set_sync(x) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - - end subroutine i2_base_set_sync + interface + module subroutine i2_base_set_sync(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_set_sync + end interface ! !> Function base_is_dev: @@ -978,13 +599,12 @@ contains !! \brief Is vector on external device . !! ! - function i2_base_is_dev(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - logical :: res - - res = .false. - end function i2_base_is_dev + interface + module function i2_base_is_dev(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + end function i2_base_is_dev + end interface ! !> Function base_is_host @@ -992,13 +612,12 @@ contains !! \brief Is vector on standard memory . !! ! - function i2_base_is_host(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function i2_base_is_host + interface + module function i2_base_is_host(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + end function i2_base_is_host + end interface ! !> Function base_is_sync @@ -1006,32 +625,24 @@ contains !! \brief Is vector on sync . !! ! - function i2_base_is_sync(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function i2_base_is_sync + interface + module function i2_base_is_sync(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + end function i2_base_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine i2_base_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - class(psb_i2_base_vect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine i2_base_cpy + interface + module subroutine i2_base_cpy(x, y) + class(psb_i2_base_vect_type), intent(in) :: x + class(psb_i2_base_vect_type), intent(out) :: y + end subroutine i2_base_cpy + end interface ! ! Size info. @@ -1042,15 +653,12 @@ contains !! \brief Number of entries !! ! - function i2_base_get_nrows(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v) - - end function i2_base_get_nrows + interface + module function i2_base_get_nrows(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_get_nrows + end interface ! !> Function base_get_sizeof @@ -1058,15 +666,12 @@ contains !! \brief Size in bytes !! ! - function i2_base_sizeof(x) result(res) - implicit none - class(psb_i2_base_vect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_i2p) * x%get_nrows() - - end function i2_base_sizeof + interface + module function i2_base_sizeof(x) result(res) + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i2_base_sizeof + end interface ! !> Function base_get_fmt @@ -1074,12 +679,11 @@ contains !! \brief Format !! ! - function i2_base_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function i2_base_get_fmt - + interface + module function i2_base_get_fmt() result(res) + character(len=5) :: res + end function i2_base_get_fmt + end interface ! ! @@ -1089,34 +693,14 @@ contains !! \brief Extract a copy of the contents !! ! - function i2_base_get_vect(x,n) result(res) - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_i2pk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - ! Local variables - integer(psb_ipk_) :: isz, i - - if (.not.allocated(x%v)) return - if (.not.x%is_host()) call x%sync() - isz = x%get_nrows() - if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') - return - end if - if (.false.) then - res(1:isz) = x%v(1:isz) - else - !$omp parallel do private(i) - do i=1, isz - res(i) = x%v(i) - end do - end if - - end function i2_base_get_vect - + interface + module function i2_base_get_vect(x,n) result(res) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function i2_base_get_vect + end interface + ! ! Reset all values ! @@ -1126,32 +710,13 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine i2_base_set_scal(x,val,first,last) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i - - first_=1 - last_=size(x%v) - if (present(first)) first_ = max(1,first) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val - end do -#else - x%v(first_:last_) = val -#endif - call x%set_host() - - end subroutine i2_base_set_scal - + interface + module subroutine i2_base_set_scal(x,val,first,last) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine i2_base_set_scal + end interface ! !> Function base_set_vect @@ -1159,45 +724,20 @@ contains !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine i2_base_set_vect(x,val,first,last) - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i, info - - if (.not.allocated(x%v)) then - call psb_realloc(size(val),x%v,info) - end if - - first_ = 1 - if (present(first)) first_ = max(1,first) - last_ = min(psb_size(x%v),first_+size(val)-1) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() - -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val(i-first_+1) - end do -#else - x%v(first_:last_) = val(1:last_-first_+1) -#endif - call x%set_host() - - end subroutine i2_base_set_vect - - subroutine i2_base_check_addr(x) - class(psb_i2_base_vect_type), intent(inout) :: x - - write(0,*) 'Check addr: base version, do nothing' - - end subroutine i2_base_check_addr - - + interface + module subroutine i2_base_set_vect(x,val,first,last) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine i2_base_set_vect + end interface + + interface + module subroutine i2_base_check_addr(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_check_addr + end interface + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -1211,18 +751,15 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine i2_base_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: alpha, beta, y(:) - class(psb_i2_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,alpha,x%v,beta,y) - - end subroutine i2_base_gthab + interface + module subroutine i2_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_base_vect_type) :: x + end subroutine i2_base_gthab + end interface + ! ! shortcut alpha=1 beta=0 ! @@ -1232,77 +769,60 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i2_base_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - integer(psb_i2pk_) :: y(:) - class(psb_i2_base_vect_type) :: x - - if (idx%is_dev()) call idx%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine i2_base_gthzv_x - + interface + module subroutine i2_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: y(:) + class(psb_i2_base_vect_type) :: x + end subroutine i2_base_gthzv_x + end interface + ! ! New comm internals impl. ! - subroutine i2_base_gthzbuf(i,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - class(psb_i2_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),x%combuf(i:)) - - end subroutine i2_base_gthzbuf + interface + module subroutine i2_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_i2_base_vect_type) :: x + end subroutine i2_base_gthzbuf + end interface + ! !> Function base_device_wait: !! \memberof psb_i2_base_vect_type !! \brief device_wait: base version is a no-op. !! ! - subroutine i2_base_device_wait() - implicit none - - end subroutine i2_base_device_wait - - function i2_base_use_buffer() result(res) - logical :: res - - res = .true. - end function i2_base_use_buffer - - subroutine i2_base_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%combuf,info) - end subroutine i2_base_new_buffer - - subroutine i2_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine i2_base_new_comid + interface + module subroutine i2_base_device_wait() + end subroutine i2_base_device_wait + end interface + interface + module function i2_base_use_buffer() result(res) + logical :: res + end function i2_base_use_buffer + end interface + + interface + module subroutine i2_base_new_buffer(n,x,info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_new_buffer + end interface + + interface + module subroutine i2_base_new_comid(n,x,info) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_new_comid + end interface ! ! shortcut alpha=1 beta=0 @@ -1313,18 +833,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i2_base_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: y(:) - class(psb_i2_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,x%v,y) - - end subroutine i2_base_gthzv + interface + module subroutine i2_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_base_vect_type) :: x + end subroutine i2_base_gthzv + end interface ! ! Scatter: @@ -1339,63 +855,73 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine i2_base_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: beta, x(:) - class(psb_i2_base_vect_type) :: y - - if (y%is_dev()) call y%sync() - call psi_sct(n,idx,x,beta,y%v) - call y%set_host() - - end subroutine i2_base_sctb - - subroutine i2_base_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_i2pk_) :: beta, x(:) - class(psb_i2_base_vect_type) :: y - - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),x,beta) - call y%set_host() - - end subroutine i2_base_sctb_x - - subroutine i2_base_sctb_buf(i,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_i2pk_) :: beta - class(psb_i2_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),y%combuf(i:),beta) - call y%set_host() - - end subroutine i2_base_sctb_buf + interface + module subroutine i2_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_base_vect_type) :: y + end subroutine i2_base_sctb + end interface + + interface + module subroutine i2_base_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_base_vect_type) :: y + end subroutine i2_base_sctb_x + end interface + + interface + module subroutine i2_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: beta + class(psb_i2_base_vect_type) :: y + end subroutine i2_base_sctb_buf + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_i2pk_) :: x(:) + type(psb_i2_base_vect_type) :: this + integer(psb_ipk_) :: info + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_i2_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const end module psb_i2_base_vect_mod module psb_i2_base_multivect_mod - use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_i2_base_vect_mod @@ -1410,8 +936,6 @@ module psb_i2_base_multivect_mod !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private - public :: psb_i2_base_multivect, psb_i2_base_multivect_type type psb_i2_base_multivect_type !> Values. @@ -1524,43 +1048,13 @@ module psb_i2_base_multivect_mod generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_i2_base_multivect_type + public :: psb_i2_base_multivect, psb_i2_base_multivect_type + interface psb_i2_base_multivect module procedure constructor, size_const end interface psb_i2_base_multivect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - integer(psb_i2pk_) :: x(:,:) - type(psb_i2_base_multivect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),& - & size(x,dim=2,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_i2_base_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(m,n,info) - - end function size_const + private ! ! Build from a sample @@ -1571,21 +1065,14 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine i2_base_mlv_bld_x(x,this) - use psb_realloc_mod - integer(psb_i2pk_), intent(in) :: this(:,:) - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - - call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') - return - end if - x%v(:,:) = this(:,:) - - end subroutine i2_base_mlv_bld_x - + interface + module subroutine i2_base_mlv_bld_x(x,this) + integer(psb_i2pk_), intent(in) :: this(:,:) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + end subroutine i2_base_mlv_bld_x + end interface + ! ! Create with size, but no initialization ! @@ -1595,18 +1082,15 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i2_base_mlv_bld_n(x,m,n,scratch) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: m,n - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch=scratch) - - end subroutine i2_base_mlv_bld_n - + interface + module subroutine i2_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + end subroutine i2_base_mlv_bld_n + end interface + !> Function base_mlv_all: !! \memberof psb_i2_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1614,21 +1098,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine i2_base_mlv_all(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i2_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(m,n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine i2_base_mlv_all + interface + module subroutine i2_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_all + end interface !> Function base_mlv_mold: !! \memberof psb_i2_base_multivect_type @@ -1636,34 +1112,20 @@ contains !! \param y returned variable !! \param info return code !! - subroutine i2_base_mlv_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - class(psb_i2_base_multivect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_i2_base_multivect_type :: y, stat=info) - - end subroutine i2_base_mlv_mold - - subroutine i2_base_mlv_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i2_base_mlv_mold(x, y, info) + class(psb_i2_base_multivect_type), intent(in) :: x + class(psb_i2_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_mold + end interface - info = 0 - if (allocated(x%v)) then - call x%sync() - x%v(:,:) = i2zero - call x%set_host() - call x%set_upd() - end if - - end subroutine i2_base_mlv_reinit + interface + module subroutine i2_base_mlv_reinit(x, info) + class(psb_i2_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -1692,129 +1154,15 @@ contains !! \param info return code !! ! - subroutine i2_base_mlv_ins(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_i2pk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - nc = size(x%v,2) - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_realloc(isz,nc,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k,:) = val(i,:) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_mlv_vect_ins') - return - end if - - end subroutine i2_base_mlv_ins + interface + module subroutine i2_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_ins + end interface ! !> Function base_mlv_zero @@ -1822,16 +1170,11 @@ contains !! \brief Zero out contents !! ! - subroutine i2_base_mlv_zero(x) - use psi_serial_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) x%v=i2zero - call x%set_host() - - end subroutine i2_base_mlv_zero - + interface + module subroutine i2_base_mlv_zero(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_zero + end interface ! ! Assembly. @@ -1846,81 +1189,15 @@ contains !! \param info return code !! ! - - subroutine i2_base_mlv_asb(m,n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_i2pk_), allocatable :: vv(:,:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(m,n,vv,info) - vv(:,:) = i2zero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i),:) = x%v(i,:) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (any(vv(x%iv(i),:).ne.i2zero)) then - info = psb_err_duplicate_coo - call psb_errpush(info,'mvect-asb') - return - else - vv(x%iv(i),:) = x%v(i,:) - end if - end do - case default - write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: @@ -1930,118 +1207,106 @@ contains !! \param info return code !! ! - subroutine i2_base_mlv_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - - end subroutine i2_base_mlv_free - - function i2_base_mlv_get_ncfs(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function i2_base_mlv_get_ncfs - - function i2_base_mlv_get_dupl(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function i2_base_mlv_get_dupl - - function i2_base_mlv_get_state(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function i2_base_mlv_get_state - - function i2_base_mlv_is_null(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function i2_base_mlv_is_null - - function i2_base_mlv_is_bld(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function i2_base_mlv_is_bld - - function i2_base_mlv_is_upd(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function i2_base_mlv_is_upd - - function i2_base_mlv_is_asb(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function i2_base_mlv_is_asb - - subroutine i2_base_mlv_set_ncfs(n,x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine i2_base_mlv_set_ncfs - - subroutine i2_base_mlv_set_dupl(n,x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine i2_base_mlv_set_dupl - - subroutine i2_base_mlv_set_state(n,x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine i2_base_mlv_set_state - - subroutine i2_base_mlv_set_null(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine i2_base_mlv_set_null - - subroutine i2_base_mlv_set_bld(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine i2_base_mlv_set_bld - - subroutine i2_base_mlv_set_upd(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine i2_base_mlv_set_upd - - subroutine i2_base_mlv_set_asb(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine i2_base_mlv_set_asb - + interface + module subroutine i2_base_mlv_free(x, info) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_free + end interface + + interface + module function i2_base_mlv_get_ncfs(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_mlv_get_ncfs + end interface + + interface + module function i2_base_mlv_get_dupl(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_mlv_get_dupl + end interface + + interface + module function i2_base_mlv_get_state(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_mlv_get_state + end interface + + interface + module function i2_base_mlv_is_null(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + end function i2_base_mlv_is_null + end interface + + interface + module function i2_base_mlv_is_bld(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + end function i2_base_mlv_is_bld + end interface + + interface + module function i2_base_mlv_is_upd(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + end function i2_base_mlv_is_upd + end interface + + interface + module function i2_base_mlv_is_asb(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + end function i2_base_mlv_is_asb + end interface + + interface + module subroutine i2_base_mlv_set_ncfs(n,x) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i2_base_mlv_set_ncfs + end interface + + interface + module subroutine i2_base_mlv_set_dupl(n,x) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i2_base_mlv_set_dupl + end interface + + interface + module subroutine i2_base_mlv_set_state(n,x) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i2_base_mlv_set_state + end interface + + interface + module subroutine i2_base_mlv_set_null(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_set_null + end interface + + interface + module subroutine i2_base_mlv_set_bld(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_set_bld + end interface + + interface + module subroutine i2_base_mlv_set_upd(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_set_upd + end interface + + interface + module subroutine i2_base_mlv_set_asb(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -2053,11 +1318,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine i2_base_mlv_sync(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - end subroutine i2_base_mlv_sync + interface + module subroutine i2_base_mlv_sync(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_sync + end interface ! !> Function base_mlv_set_host: @@ -2065,11 +1330,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine i2_base_mlv_set_host(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - end subroutine i2_base_mlv_set_host + interface + module subroutine i2_base_mlv_set_host(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_set_host + end interface ! !> Function base_mlv_set_dev: @@ -2077,11 +1342,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine i2_base_mlv_set_dev(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - end subroutine i2_base_mlv_set_dev + interface + module subroutine i2_base_mlv_set_dev(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_set_dev + end interface ! !> Function base_mlv_set_sync: @@ -2089,11 +1354,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine i2_base_mlv_set_sync(x) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - - end subroutine i2_base_mlv_set_sync + interface + module subroutine i2_base_mlv_set_sync(x) + class(psb_i2_base_multivect_type), intent(inout) :: x + end subroutine i2_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -2101,13 +1366,12 @@ contains !! \brief Is vector on external device . !! ! - function i2_base_mlv_is_dev(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - logical :: res - - res = .false. - end function i2_base_mlv_is_dev + interface + module function i2_base_mlv_is_dev(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + end function i2_base_mlv_is_dev + end interface ! !> Function base_mlv_is_host @@ -2115,13 +1379,12 @@ contains !! \brief Is vector on standard memory . !! ! - function i2_base_mlv_is_host(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function i2_base_mlv_is_host + interface + module function i2_base_mlv_is_host(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + end function i2_base_mlv_is_host + end interface ! !> Function base_mlv_is_sync @@ -2129,35 +1392,25 @@ contains !! \brief Is vector on sync . !! ! - function i2_base_mlv_is_sync(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function i2_base_mlv_is_sync + interface + module function i2_base_mlv_is_sync(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + end function i2_base_mlv_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine i2_base_mlv_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - class(psb_i2_base_multivect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine i2_base_mlv_cpy - + interface + module subroutine i2_base_mlv_cpy(x, y) + class(psb_i2_base_multivect_type), intent(in) :: x + class(psb_i2_base_multivect_type), intent(out) :: y + end subroutine i2_base_mlv_cpy + end interface - ! ! Size info. ! ! @@ -2166,25 +1419,19 @@ contains !! \brief Number of entries !! ! - function i2_base_mlv_get_nrows(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function i2_base_mlv_get_nrows + interface + module function i2_base_mlv_get_nrows(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_mlv_get_nrows + end interface - function i2_base_mlv_get_ncols(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,2) - - end function i2_base_mlv_get_ncols + interface + module function i2_base_mlv_get_ncols(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i2_base_mlv_get_ncols + end interface ! !> Function base_mlv_get_sizeof @@ -2192,15 +1439,12 @@ contains !! \brief Size in bytesa !! ! - function i2_base_mlv_sizeof(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_i2p) * x%get_nrows() * x%get_ncols() - - end function i2_base_mlv_sizeof + interface + module function i2_base_mlv_sizeof(x) result(res) + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i2_base_mlv_sizeof + end interface ! !> Function base_mlv_get_fmt @@ -2208,12 +1452,11 @@ contains !! \brief Format !! ! - function i2_base_mlv_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function i2_base_mlv_get_fmt - + interface + module function i2_base_mlv_get_fmt() result(res) + character(len=5) :: res + end function i2_base_mlv_get_fmt + end interface ! ! @@ -2223,22 +1466,12 @@ contains !! \brief Extract a copy of the contents !! ! - function i2_base_mlv_get_vect(x) result(res) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_i2pk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info,m,n - m = x%get_nrows() - n = x%get_ncols() - if (.not.allocated(x%v)) return - call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') - return - end if - res(1:m,1:n) = x%v(1:m,1:n) - end function i2_base_mlv_get_vect + interface + module function i2_base_mlv_get_vect(x) result(res) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:,:) + end function i2_base_mlv_get_vect + end interface ! ! Reset all values @@ -2249,104 +1482,69 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine i2_base_mlv_set_scal(x,val) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val - - integer(psb_ipk_) :: info - x%v = val - - end subroutine i2_base_mlv_set_scal - + interface + module subroutine i2_base_mlv_set_scal(x,val) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + end subroutine i2_base_mlv_set_scal + end interface + ! !> Function base_mlv_set_vect !! \memberof psb_i2_base_multivect_type !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine i2_base_mlv_set_vect(x,val) - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_i2pk_), intent(in) :: val(:,:) - integer(psb_ipk_) :: nr, nc - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - nr = min(size(x%v,1),size(val,1)) - nc = min(size(x%v,2),size(val,2)) - - x%v(1:nr,1:nc) = val(1:nr,1:nc) - else - x%v = val - end if - - end subroutine i2_base_mlv_set_vect - - - function i2_base_mlv_use_buffer() result(res) - implicit none - logical :: res - - res = .true. - end function i2_base_mlv_use_buffer - - subroutine i2_base_mlv_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i2_base_mlv_set_vect(x,val) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:,:) + end subroutine i2_base_mlv_set_vect + end interface - integer(psb_ipk_) :: nc - nc = x%get_ncols() - call psb_realloc(n*nc,x%combuf,info) - end subroutine i2_base_mlv_new_buffer - subroutine i2_base_mlv_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine i2_base_mlv_new_comid - - - subroutine i2_base_mlv_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine i2_base_mlv_maybe_free_buffer - - subroutine i2_base_mlv_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine i2_base_mlv_free_buffer - - subroutine i2_base_mlv_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_i2_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine i2_base_mlv_free_comid + interface + module function i2_base_mlv_use_buffer() result(res) + logical :: res + end function i2_base_mlv_use_buffer + end interface + + interface + module subroutine i2_base_mlv_new_buffer(n,x,info) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_new_buffer + end interface + + interface + module subroutine i2_base_mlv_new_comid(n,x,info) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_new_comid + end interface + + interface + module subroutine i2_base_mlv_maybe_free_buffer(x,info) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_maybe_free_buffer + end interface + + interface + module subroutine i2_base_mlv_free_buffer(x,info) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_free_buffer + end interface + interface + module subroutine i2_base_mlv_free_comid(x,info) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i2_base_mlv_free_comid + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -2360,23 +1558,14 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine i2_base_mlv_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: alpha, beta, y(:) - class(psb_i2_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - call psi_gth(n,nc,idx,alpha,x%v,beta,y) - - end subroutine i2_base_mlv_gthab + interface + module subroutine i2_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_base_multivect_type) :: x + end subroutine i2_base_mlv_gthab + end interface ! ! shortcut alpha=1 beta=0 ! @@ -2386,19 +1575,15 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i2_base_mlv_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_i2pk_) :: y(:) - class(psb_i2_base_multivect_type) :: x - - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine i2_base_mlv_gthzv_x + interface + module subroutine i2_base_mlv_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_base_multivect_type) :: x + end subroutine i2_base_mlv_gthzv_x + end interface ! ! shortcut alpha=1 beta=0 @@ -2409,24 +1594,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i2_base_mlv_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: y(:) - class(psb_i2_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine i2_base_mlv_gthzv + interface + module subroutine i2_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_base_multivect_type) :: x + end subroutine i2_base_mlv_gthzv + end interface ! ! shortcut alpha=1 beta=0 ! @@ -2436,48 +1611,27 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i2_base_mlv_gthzm(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: y(:,:) - class(psb_i2_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine i2_base_mlv_gthzm + interface + module subroutine i2_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:,:) + class(psb_i2_base_multivect_type) :: x + end subroutine i2_base_mlv_gthzm + end interface ! ! New comm internals impl. ! - subroutine i2_base_mlv_gthzbuf(i,ixb,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, ixb - class(psb_i_base_vect_type) :: idx - class(psb_i2_base_multivect_type) :: x - integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - nc = x%get_ncols() - call x%gth(n,idx%v(i:),x%combuf(ixb:)) - - end subroutine i2_base_mlv_gthzbuf - + interface + module subroutine i2_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_i2_base_multivect_type) :: x + end subroutine i2_base_mlv_gthzbuf + end interface + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -2491,72 +1645,43 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine i2_base_mlv_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: beta, x(:) - class(psb_i2_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = psb_size(y%v,2_psb_ipk_) - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine i2_base_mlv_sctb - - subroutine i2_base_mlv_sctbr2(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_i2pk_) :: beta, x(:,:) - class(psb_i2_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = y%get_ncols() - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine i2_base_mlv_sctbr2 - - subroutine i2_base_mlv_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer( psb_i2pk_) :: beta, x(:) - class(psb_i2_base_multivect_type) :: y - - call y%sct(n,idx%v(i:),x,beta) - - end subroutine i2_base_mlv_sctb_x - - subroutine i2_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, iyb - class(psb_i_base_vect_type) :: idx - integer(psb_i2pk_) :: beta - class(psb_i2_base_multivect_type) :: y - integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - nc = y%get_ncols() - call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) - call y%set_host() - - end subroutine i2_base_mlv_sctb_buf + interface + module subroutine i2_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_base_multivect_type) :: y + end subroutine i2_base_mlv_sctb + end interface + + interface + module subroutine i2_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:,:) + class(psb_i2_base_multivect_type) :: y + end subroutine i2_base_mlv_sctbr2 + end interface + + interface + module subroutine i2_base_mlv_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_base_multivect_type) :: y + end subroutine i2_base_mlv_sctb_x + end interface + + interface + module subroutine i2_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: beta + class(psb_i2_base_multivect_type) :: y + end subroutine i2_base_mlv_sctb_buf + end interface ! !> Function base_device_wait: @@ -2564,9 +1689,43 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine i2_base_mlv_device_wait() - implicit none + interface + module subroutine i2_base_mlv_device_wait() + end subroutine i2_base_mlv_device_wait + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_i2pk_) :: x(:,:) + type(psb_i2_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_i2_base_multivect_type) :: this + integer(psb_ipk_) :: info - end subroutine i2_base_mlv_device_wait + call this%asb(m,n,info) + + end function size_const end module psb_i2_base_multivect_mod diff --git a/base/modules/serial/psb_i2_vect_mod.F90 b/base/modules/serial/psb_i2_vect_mod.F90 index b05c2ffba..955464dad 100644 --- a/base/modules/serial/psb_i2_vect_mod.F90 +++ b/base/modules/serial/psb_i2_vect_mod.F90 @@ -111,7 +111,10 @@ module psb_i2_vect_mod end type psb_i2_vect_type - public :: psb_i2_vect + public :: psb_i2_vect, psb_i2_vect_type,& + & psb_i2_set_vect_default, psb_i2_get_vect_default, & + & psb_i2_clear_vect_default, psb_i2_base_vect_type + private :: constructor, size_const interface psb_i2_vect module procedure constructor, size_const @@ -133,180 +136,366 @@ module psb_i2_vect_mod class(psb_i2_base_vect_type), allocatable, target,& & save, private :: psb_i2_base_vect_default - interface psb_set_vect_default - module procedure psb_i2_set_vect_default - end interface psb_set_vect_default - - 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 + interface + module function i2_vect_get_dupl(x) result(res) + 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 + 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 + 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 - 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 - +contains + 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 @@ -317,7 +506,6 @@ contains 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 @@ -326,7 +514,6 @@ contains 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) @@ -335,7 +522,6 @@ contains 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 @@ -346,150 +532,6 @@ contains 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) - - 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 - function constructor(x) result(this) integer(psb_i2pk_) :: x(:) type(psb_i2_vect_type) :: this @@ -511,296 +553,6 @@ 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 @@ -810,7 +562,6 @@ module psb_i2_multivect_mod use psb_const_mod use psb_i_vect_mod - !private type psb_i2_multivect_type @@ -855,71 +606,233 @@ module psb_i2_multivect_mod end type psb_i2_multivect_type public :: psb_i2_multivect, psb_i2_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default, & - & psb_i2_base_multivect_type + & psb_i2_set_multivect_default, psb_i2_get_base_multivect_default, & + & psb_i2_clear_multivect_default, psb_i2_base_multivect_type - private interface psb_i2_multivect module procedure constructor, size_const end interface psb_i2_multivect + private + 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 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 + integer(psb_ipk_) :: info + 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 @@ -929,18 +842,16 @@ contains 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_multivect_default(v) result(res) +!!$ 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 @@ -951,85 +862,6 @@ contains 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) integer(psb_i2pk_) :: x(:,:) type(psb_i2_multivect_type) :: this @@ -1040,7 +872,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,222 +882,13 @@ 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 + + subroutine psb_i2_clear_multivect_default() - 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) + if (allocated(psb_i2_base_multivect_default)) then + deallocate(psb_i2_base_multivect_default) end if - call move_alloc(tmp,x%v) - end subroutine i2_mvect_cnv + end subroutine psb_i2_clear_multivect_default end module psb_i2_multivect_mod diff --git a/base/modules/serial/psb_i_base_vect_mod.F90 b/base/modules/serial/psb_i_base_vect_mod.F90 index 31cd5f92c..7967e1282 100644 --- a/base/modules/serial/psb_i_base_vect_mod.F90 +++ b/base/modules/serial/psb_i_base_vect_mod.F90 @@ -177,45 +177,12 @@ module psb_i_base_vect_mod end type psb_i_base_vect_type - public :: psb_i_base_vect + public :: psb_i_base_vect, psb_i_base_vect_type private :: constructor, size_const interface psb_i_base_vect module procedure constructor, size_const end interface psb_i_base_vect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - integer(psb_ipk_) :: x(:) - type(psb_i_base_vect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(n) result(this) - integer(psb_ipk_), intent(in) :: n - type(psb_i_base_vect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(n,info) - - end function size_const - ! ! Build from a sample ! @@ -225,36 +192,13 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine i_base_bld_x(x,this,scratch) - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: this(:) - class(psb_i_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - integer(psb_ipk_) :: i - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(size(this),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') - return - end if -#if defined (PSB_OPENMP) - !$omp parallel do private(i) - do i = 1, size(this) - x%v(i) = this(i) - end do -#else - x%v(:) = this(:) -#endif - end subroutine i_base_bld_x + interface + module subroutine i_base_bld_x(x,this,scratch) + integer(psb_ipk_), intent(in) :: this(:) + class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine i_base_bld_x + end interface ! ! Create with size, but no initialization @@ -265,50 +209,26 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_bld_mn(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_i_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine i_base_bld_mn - + interface + module subroutine i_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine i_base_bld_mn + end interface + !> Function bld_en: !! \memberof psb_i_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_bld_en(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_i_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine i_base_bld_en + interface + module subroutine i_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine i_base_bld_en + end interface !> Function base_all: !! \memberof psb_i_base_vect_type @@ -317,21 +237,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine i_base_all(n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_i_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine i_base_all + interface + module subroutine i_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_i_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_all + end interface !> Function base_mold: !! \memberof psb_i_base_vect_type @@ -339,42 +251,21 @@ contains !! \param y returned variable !! \param info return code !! - subroutine i_base_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(in) :: x - class(psb_i_base_vect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_i_base_vect_type :: y, stat=info) - - end subroutine i_base_mold - - subroutine i_base_reinit(x, info,clear) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - logical :: clear_ - - info = 0 - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - if (clear_) x%v(:) = izero - call x%set_host() - call x%set_upd() - end if + interface + module subroutine i_base_mold(x, y, info) + class(psb_i_base_vect_type), intent(in) :: x + class(psb_i_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mold + end interface - end subroutine i_base_reinit + interface + module subroutine i_base_reinit(x, info,clear) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine i_base_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -403,152 +294,27 @@ contains !! \param info return code !! ! - subroutine i_base_ins_a(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine i_base_ins_a - - subroutine i_base_ins_v(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - class(psb_i_base_vect_type), intent(inout) :: irl - class(psb_i_base_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: isz - - info = 0 - if (psb_errstatus_fatal()) return - - if (irl%is_dev()) call irl%sync() - if (val%is_dev()) call val%sync() - if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,maxr,info) - - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine i_base_ins_v + interface + module subroutine i_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_ins_a + end interface + + + interface + module subroutine i_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_i_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_ins_v + end interface + ! @@ -557,18 +323,12 @@ contains !! \brief Zero out contents !! ! - subroutine i_base_zero(x) - use psi_serial_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x + interface + module subroutine i_base_zero(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_zero + end interface - if (allocated(x%v)) then - !$omp workshare - x%v(:)=izero - !$omp end workshare - end if - call x%set_host() - end subroutine i_base_zero ! @@ -585,74 +345,15 @@ contains !! ! - subroutine i_base_asb_m(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_ipk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(n,vv,info) - vv(:) = izero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (vv(x%iv(i)).ne. izero) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine i_base_asb_m + interface + module subroutine i_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine i_base_asb_m + end interface + ! ! Assembly. @@ -668,74 +369,15 @@ contains !! ! - subroutine i_base_asb_e(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_ipk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') - if (x%is_bld()) then - call psb_realloc(n,vv,info) - vv(:) = izero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne. izero) then - call psb_errpush(psb_err_duplicate_coo,'vect_asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine i_base_asb_e + interface + module subroutine i_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine i_base_asb_e + end interface + ! !> Function base_free: @@ -745,22 +387,13 @@ contains !! \param info return code !! ! - subroutine i_base_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i_base_free(x, info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_free + end interface - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - call x%set_null() - end subroutine i_base_free ! !> Function base_free_buffer: @@ -770,15 +403,13 @@ contains !! \param info return code !! ! - subroutine i_base_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i_base_free_buffer(x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_free_buffer + end interface - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine i_base_free_buffer ! !> Function base_maybe_free_buffer: @@ -791,17 +422,13 @@ contains !! \param info return code !! ! - subroutine i_base_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i_base_maybe_free_buffer(x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_maybe_free_buffer + end interface - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine i_base_maybe_free_buffer ! !> Function base_free_comid: @@ -811,113 +438,107 @@ contains !! \param info return code !! ! - subroutine i_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine i_base_free_comid - - function i_base_get_ncfs(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function i_base_get_ncfs - - function i_base_get_dupl(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function i_base_get_dupl - - function i_base_get_state(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function i_base_get_state - - function i_base_is_null(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function i_base_is_null - - function i_base_is_bld(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function i_base_is_bld - - function i_base_is_upd(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function i_base_is_upd - - function i_base_is_asb(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function i_base_is_asb - - subroutine i_base_set_ncfs(n,x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine i_base_set_ncfs - - subroutine i_base_set_dupl(n,x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine i_base_set_dupl - - subroutine i_base_set_state(n,x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine i_base_set_state - - subroutine i_base_set_null(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine i_base_set_null - - subroutine i_base_set_bld(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine i_base_set_bld - - subroutine i_base_set_upd(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine i_base_set_upd - - subroutine i_base_set_asb(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine i_base_set_asb + interface + module subroutine i_base_free_comid(x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_free_comid + end interface + + + interface + module function i_base_get_ncfs(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_get_ncfs + end interface + + interface + module function i_base_get_dupl(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_get_dupl + end interface + + interface + module function i_base_get_state(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_get_state + end interface + + interface + module function i_base_is_null(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + end function i_base_is_null + end interface + + interface + module function i_base_is_bld(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + end function i_base_is_bld + end interface + + interface + module function i_base_is_upd(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + end function i_base_is_upd + end interface + + interface + module function i_base_is_asb(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + end function i_base_is_asb + end interface + + interface + module subroutine i_base_set_ncfs(n,x) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i_base_set_ncfs + end interface + + interface + module subroutine i_base_set_dupl(n,x) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i_base_set_dupl + end interface + + interface + module subroutine i_base_set_state(n,x) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i_base_set_state + end interface + + interface + module subroutine i_base_set_null(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_set_null + end interface + + interface + module subroutine i_base_set_bld(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_set_bld + end interface + + interface + module subroutine i_base_set_upd(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_set_upd + end interface + + interface + module subroutine i_base_set_asb(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -929,11 +550,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine i_base_sync(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - end subroutine i_base_sync + interface + module subroutine i_base_sync(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_sync + end interface ! !> Function base_set_host: @@ -941,11 +562,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine i_base_set_host(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - end subroutine i_base_set_host + interface + module subroutine i_base_set_host(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_set_host + end interface ! !> Function base_set_dev: @@ -953,11 +574,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine i_base_set_dev(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - end subroutine i_base_set_dev + interface + module subroutine i_base_set_dev(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_set_dev + end interface ! !> Function base_set_sync: @@ -965,11 +586,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine i_base_set_sync(x) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - - end subroutine i_base_set_sync + interface + module subroutine i_base_set_sync(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_set_sync + end interface ! !> Function base_is_dev: @@ -977,13 +598,12 @@ contains !! \brief Is vector on external device . !! ! - function i_base_is_dev(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - logical :: res - - res = .false. - end function i_base_is_dev + interface + module function i_base_is_dev(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + end function i_base_is_dev + end interface ! !> Function base_is_host @@ -991,13 +611,12 @@ contains !! \brief Is vector on standard memory . !! ! - function i_base_is_host(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function i_base_is_host + interface + module function i_base_is_host(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + end function i_base_is_host + end interface ! !> Function base_is_sync @@ -1005,32 +624,24 @@ contains !! \brief Is vector on sync . !! ! - function i_base_is_sync(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function i_base_is_sync + interface + module function i_base_is_sync(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + end function i_base_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine i_base_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(in) :: x - class(psb_i_base_vect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine i_base_cpy + interface + module subroutine i_base_cpy(x, y) + class(psb_i_base_vect_type), intent(in) :: x + class(psb_i_base_vect_type), intent(out) :: y + end subroutine i_base_cpy + end interface ! ! Size info. @@ -1041,15 +652,12 @@ contains !! \brief Number of entries !! ! - function i_base_get_nrows(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v) - - end function i_base_get_nrows + interface + module function i_base_get_nrows(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_get_nrows + end interface ! !> Function base_get_sizeof @@ -1057,15 +665,12 @@ contains !! \brief Size in bytes !! ! - function i_base_sizeof(x) result(res) - implicit none - class(psb_i_base_vect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() - - end function i_base_sizeof + interface + module function i_base_sizeof(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i_base_sizeof + end interface ! !> Function base_get_fmt @@ -1073,12 +678,11 @@ contains !! \brief Format !! ! - function i_base_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function i_base_get_fmt - + interface + module function i_base_get_fmt() result(res) + character(len=5) :: res + end function i_base_get_fmt + end interface ! ! @@ -1088,34 +692,14 @@ contains !! \brief Extract a copy of the contents !! ! - function i_base_get_vect(x,n) result(res) - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - ! Local variables - integer(psb_ipk_) :: isz, i - - if (.not.allocated(x%v)) return - if (.not.x%is_host()) call x%sync() - isz = x%get_nrows() - if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') - return - end if - if (.false.) then - res(1:isz) = x%v(1:isz) - else - !$omp parallel do private(i) - do i=1, isz - res(i) = x%v(i) - end do - end if - - end function i_base_get_vect - + interface + module function i_base_get_vect(x,n) result(res) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function i_base_get_vect + end interface + ! ! Reset all values ! @@ -1125,32 +709,13 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine i_base_set_scal(x,val,first,last) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i - - first_=1 - last_=size(x%v) - if (present(first)) first_ = max(1,first) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val - end do -#else - x%v(first_:last_) = val -#endif - call x%set_host() - - end subroutine i_base_set_scal - + interface + module subroutine i_base_set_scal(x,val,first,last) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine i_base_set_scal + end interface ! !> Function base_set_vect @@ -1158,45 +723,20 @@ contains !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine i_base_set_vect(x,val,first,last) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i, info - - if (.not.allocated(x%v)) then - call psb_realloc(size(val),x%v,info) - end if - - first_ = 1 - if (present(first)) first_ = max(1,first) - last_ = min(psb_size(x%v),first_+size(val)-1) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() - -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val(i-first_+1) - end do -#else - x%v(first_:last_) = val(1:last_-first_+1) -#endif - call x%set_host() - - end subroutine i_base_set_vect - - subroutine i_base_check_addr(x) - class(psb_i_base_vect_type), intent(inout) :: x - - write(0,*) 'Check addr: base version, do nothing' - - end subroutine i_base_check_addr - - + interface + module subroutine i_base_set_vect(x,val,first,last) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine i_base_set_vect + end interface + + interface + module subroutine i_base_check_addr(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_check_addr + end interface + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -1210,18 +750,15 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine i_base_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: alpha, beta, y(:) - class(psb_i_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,alpha,x%v,beta,y) - - end subroutine i_base_gthab + interface + module subroutine i_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_base_vect_type) :: x + end subroutine i_base_gthab + end interface + ! ! shortcut alpha=1 beta=0 ! @@ -1231,77 +768,60 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i_base_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - integer(psb_ipk_) :: y(:) - class(psb_i_base_vect_type) :: x - - if (idx%is_dev()) call idx%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine i_base_gthzv_x - + interface + module subroutine i_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: y(:) + class(psb_i_base_vect_type) :: x + end subroutine i_base_gthzv_x + end interface + ! ! New comm internals impl. ! - subroutine i_base_gthzbuf(i,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - class(psb_i_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),x%combuf(i:)) - - end subroutine i_base_gthzbuf + interface + module subroutine i_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_i_base_vect_type) :: x + end subroutine i_base_gthzbuf + end interface + ! !> Function base_device_wait: !! \memberof psb_i_base_vect_type !! \brief device_wait: base version is a no-op. !! ! - subroutine i_base_device_wait() - implicit none - - end subroutine i_base_device_wait - - function i_base_use_buffer() result(res) - logical :: res - - res = .true. - end function i_base_use_buffer - - subroutine i_base_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%combuf,info) - end subroutine i_base_new_buffer - - subroutine i_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine i_base_new_comid + interface + module subroutine i_base_device_wait() + end subroutine i_base_device_wait + end interface + interface + module function i_base_use_buffer() result(res) + logical :: res + end function i_base_use_buffer + end interface + + interface + module subroutine i_base_new_buffer(n,x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_new_buffer + end interface + + interface + module subroutine i_base_new_comid(n,x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_new_comid + end interface ! ! shortcut alpha=1 beta=0 @@ -1312,18 +832,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i_base_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: y(:) - class(psb_i_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,x%v,y) - - end subroutine i_base_gthzv + interface + module subroutine i_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_base_vect_type) :: x + end subroutine i_base_gthzv + end interface ! ! Scatter: @@ -1338,63 +854,73 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine i_base_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: beta, x(:) - class(psb_i_base_vect_type) :: y - - if (y%is_dev()) call y%sync() - call psi_sct(n,idx,x,beta,y%v) - call y%set_host() - - end subroutine i_base_sctb - - subroutine i_base_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_ipk_) :: beta, x(:) - class(psb_i_base_vect_type) :: y - - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),x,beta) - call y%set_host() - - end subroutine i_base_sctb_x - - subroutine i_base_sctb_buf(i,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_ipk_) :: beta - class(psb_i_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),y%combuf(i:),beta) - call y%set_host() - - end subroutine i_base_sctb_buf + interface + module subroutine i_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_base_vect_type) :: y + end subroutine i_base_sctb + end interface + + interface + module subroutine i_base_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_base_vect_type) :: y + end subroutine i_base_sctb_x + end interface + + interface + module subroutine i_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta + class(psb_i_base_vect_type) :: y + end subroutine i_base_sctb_buf + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_ipk_) :: x(:) + type(psb_i_base_vect_type) :: this + integer(psb_ipk_) :: info + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_i_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const end module psb_i_base_vect_mod module psb_i_base_multivect_mod - use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod @@ -1409,8 +935,6 @@ module psb_i_base_multivect_mod !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private - public :: psb_i_base_multivect, psb_i_base_multivect_type type psb_i_base_multivect_type !> Values. @@ -1523,43 +1047,13 @@ module psb_i_base_multivect_mod generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_i_base_multivect_type + public :: psb_i_base_multivect, psb_i_base_multivect_type + interface psb_i_base_multivect module procedure constructor, size_const end interface psb_i_base_multivect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - integer(psb_ipk_) :: x(:,:) - type(psb_i_base_multivect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),& - & size(x,dim=2,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_i_base_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(m,n,info) - - end function size_const + private ! ! Build from a sample @@ -1570,21 +1064,14 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine i_base_mlv_bld_x(x,this) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: this(:,:) - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - - call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') - return - end if - x%v(:,:) = this(:,:) - - end subroutine i_base_mlv_bld_x - + interface + module subroutine i_base_mlv_bld_x(x,this) + integer(psb_ipk_), intent(in) :: this(:,:) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + end subroutine i_base_mlv_bld_x + end interface + ! ! Create with size, but no initialization ! @@ -1594,18 +1081,15 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_mlv_bld_n(x,m,n,scratch) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: m,n - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch=scratch) - - end subroutine i_base_mlv_bld_n - + interface + module subroutine i_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + end subroutine i_base_mlv_bld_n + end interface + !> Function base_mlv_all: !! \memberof psb_i_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1613,21 +1097,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine i_base_mlv_all(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(m,n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine i_base_mlv_all + interface + module subroutine i_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_all + end interface !> Function base_mlv_mold: !! \memberof psb_i_base_multivect_type @@ -1635,34 +1111,20 @@ contains !! \param y returned variable !! \param info return code !! - subroutine i_base_mlv_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - class(psb_i_base_multivect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_i_base_multivect_type :: y, stat=info) - - end subroutine i_base_mlv_mold - - subroutine i_base_mlv_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i_base_mlv_mold(x, y, info) + class(psb_i_base_multivect_type), intent(in) :: x + class(psb_i_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_mold + end interface - info = 0 - if (allocated(x%v)) then - call x%sync() - x%v(:,:) = izero - call x%set_host() - call x%set_upd() - end if - - end subroutine i_base_mlv_reinit + interface + module subroutine i_base_mlv_reinit(x, info) + class(psb_i_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -1691,129 +1153,15 @@ contains !! \param info return code !! ! - subroutine i_base_mlv_ins(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_ipk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - nc = size(x%v,2) - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_realloc(isz,nc,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k,:) = val(i,:) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_mlv_vect_ins') - return - end if - - end subroutine i_base_mlv_ins + interface + module subroutine i_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_ins + end interface ! !> Function base_mlv_zero @@ -1821,16 +1169,11 @@ contains !! \brief Zero out contents !! ! - subroutine i_base_mlv_zero(x) - use psi_serial_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) x%v=izero - call x%set_host() - - end subroutine i_base_mlv_zero - + interface + module subroutine i_base_mlv_zero(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_zero + end interface ! ! Assembly. @@ -1845,81 +1188,15 @@ contains !! \param info return code !! ! - - subroutine i_base_mlv_asb(m,n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_ipk_), allocatable :: vv(:,:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(m,n,vv,info) - vv(:,:) = izero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i),:) = x%v(i,:) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (any(vv(x%iv(i),:).ne.izero)) then - info = psb_err_duplicate_coo - call psb_errpush(info,'mvect-asb') - return - else - vv(x%iv(i),:) = x%v(i,:) - end if - end do - case default - write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: @@ -1929,118 +1206,106 @@ contains !! \param info return code !! ! - subroutine i_base_mlv_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - - end subroutine i_base_mlv_free - - function i_base_mlv_get_ncfs(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function i_base_mlv_get_ncfs - - function i_base_mlv_get_dupl(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function i_base_mlv_get_dupl - - function i_base_mlv_get_state(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function i_base_mlv_get_state - - function i_base_mlv_is_null(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function i_base_mlv_is_null - - function i_base_mlv_is_bld(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function i_base_mlv_is_bld - - function i_base_mlv_is_upd(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function i_base_mlv_is_upd - - function i_base_mlv_is_asb(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function i_base_mlv_is_asb - - subroutine i_base_mlv_set_ncfs(n,x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine i_base_mlv_set_ncfs - - subroutine i_base_mlv_set_dupl(n,x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine i_base_mlv_set_dupl - - subroutine i_base_mlv_set_state(n,x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine i_base_mlv_set_state - - subroutine i_base_mlv_set_null(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine i_base_mlv_set_null - - subroutine i_base_mlv_set_bld(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine i_base_mlv_set_bld - - subroutine i_base_mlv_set_upd(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine i_base_mlv_set_upd - - subroutine i_base_mlv_set_asb(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine i_base_mlv_set_asb - + interface + module subroutine i_base_mlv_free(x, info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_free + end interface + + interface + module function i_base_mlv_get_ncfs(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_mlv_get_ncfs + end interface + + interface + module function i_base_mlv_get_dupl(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_mlv_get_dupl + end interface + + interface + module function i_base_mlv_get_state(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_mlv_get_state + end interface + + interface + module function i_base_mlv_is_null(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + end function i_base_mlv_is_null + end interface + + interface + module function i_base_mlv_is_bld(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + end function i_base_mlv_is_bld + end interface + + interface + module function i_base_mlv_is_upd(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + end function i_base_mlv_is_upd + end interface + + interface + module function i_base_mlv_is_asb(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + end function i_base_mlv_is_asb + end interface + + interface + module subroutine i_base_mlv_set_ncfs(n,x) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i_base_mlv_set_ncfs + end interface + + interface + module subroutine i_base_mlv_set_dupl(n,x) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i_base_mlv_set_dupl + end interface + + interface + module subroutine i_base_mlv_set_state(n,x) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine i_base_mlv_set_state + end interface + + interface + module subroutine i_base_mlv_set_null(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_set_null + end interface + + interface + module subroutine i_base_mlv_set_bld(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_set_bld + end interface + + interface + module subroutine i_base_mlv_set_upd(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_set_upd + end interface + + interface + module subroutine i_base_mlv_set_asb(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -2052,11 +1317,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine i_base_mlv_sync(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - end subroutine i_base_mlv_sync + interface + module subroutine i_base_mlv_sync(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_sync + end interface ! !> Function base_mlv_set_host: @@ -2064,11 +1329,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine i_base_mlv_set_host(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - end subroutine i_base_mlv_set_host + interface + module subroutine i_base_mlv_set_host(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_set_host + end interface ! !> Function base_mlv_set_dev: @@ -2076,11 +1341,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine i_base_mlv_set_dev(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - end subroutine i_base_mlv_set_dev + interface + module subroutine i_base_mlv_set_dev(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_set_dev + end interface ! !> Function base_mlv_set_sync: @@ -2088,11 +1353,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine i_base_mlv_set_sync(x) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - - end subroutine i_base_mlv_set_sync + interface + module subroutine i_base_mlv_set_sync(x) + class(psb_i_base_multivect_type), intent(inout) :: x + end subroutine i_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -2100,13 +1365,12 @@ contains !! \brief Is vector on external device . !! ! - function i_base_mlv_is_dev(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - logical :: res - - res = .false. - end function i_base_mlv_is_dev + interface + module function i_base_mlv_is_dev(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + end function i_base_mlv_is_dev + end interface ! !> Function base_mlv_is_host @@ -2114,13 +1378,12 @@ contains !! \brief Is vector on standard memory . !! ! - function i_base_mlv_is_host(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function i_base_mlv_is_host + interface + module function i_base_mlv_is_host(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + end function i_base_mlv_is_host + end interface ! !> Function base_mlv_is_sync @@ -2128,35 +1391,25 @@ contains !! \brief Is vector on sync . !! ! - function i_base_mlv_is_sync(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function i_base_mlv_is_sync + interface + module function i_base_mlv_is_sync(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + end function i_base_mlv_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine i_base_mlv_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - class(psb_i_base_multivect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine i_base_mlv_cpy - + interface + module subroutine i_base_mlv_cpy(x, y) + class(psb_i_base_multivect_type), intent(in) :: x + class(psb_i_base_multivect_type), intent(out) :: y + end subroutine i_base_mlv_cpy + end interface - ! ! Size info. ! ! @@ -2165,25 +1418,19 @@ contains !! \brief Number of entries !! ! - function i_base_mlv_get_nrows(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function i_base_mlv_get_nrows + interface + module function i_base_mlv_get_nrows(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_mlv_get_nrows + end interface - function i_base_mlv_get_ncols(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,2) - - end function i_base_mlv_get_ncols + interface + module function i_base_mlv_get_ncols(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function i_base_mlv_get_ncols + end interface ! !> Function base_mlv_get_sizeof @@ -2191,15 +1438,12 @@ contains !! \brief Size in bytesa !! ! - function i_base_mlv_sizeof(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() - - end function i_base_mlv_sizeof + interface + module function i_base_mlv_sizeof(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function i_base_mlv_sizeof + end interface ! !> Function base_mlv_get_fmt @@ -2207,12 +1451,11 @@ contains !! \brief Format !! ! - function i_base_mlv_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function i_base_mlv_get_fmt - + interface + module function i_base_mlv_get_fmt() result(res) + character(len=5) :: res + end function i_base_mlv_get_fmt + end interface ! ! @@ -2222,22 +1465,12 @@ contains !! \brief Extract a copy of the contents !! ! - function i_base_mlv_get_vect(x) result(res) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info,m,n - m = x%get_nrows() - n = x%get_ncols() - if (.not.allocated(x%v)) return - call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') - return - end if - res(1:m,1:n) = x%v(1:m,1:n) - end function i_base_mlv_get_vect + interface + module function i_base_mlv_get_vect(x) result(res) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:,:) + end function i_base_mlv_get_vect + end interface ! ! Reset all values @@ -2248,104 +1481,69 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine i_base_mlv_set_scal(x,val) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val - - integer(psb_ipk_) :: info - x%v = val - - end subroutine i_base_mlv_set_scal - + interface + module subroutine i_base_mlv_set_scal(x,val) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + end subroutine i_base_mlv_set_scal + end interface + ! !> Function base_mlv_set_vect !! \memberof psb_i_base_multivect_type !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine i_base_mlv_set_vect(x,val) - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: val(:,:) - integer(psb_ipk_) :: nr, nc - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - nr = min(size(x%v,1),size(val,1)) - nc = min(size(x%v,2),size(val,2)) - - x%v(1:nr,1:nc) = val(1:nr,1:nc) - else - x%v = val - end if - - end subroutine i_base_mlv_set_vect - - - function i_base_mlv_use_buffer() result(res) - implicit none - logical :: res - - res = .true. - end function i_base_mlv_use_buffer - - subroutine i_base_mlv_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info + interface + module subroutine i_base_mlv_set_vect(x,val) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:,:) + end subroutine i_base_mlv_set_vect + end interface - integer(psb_ipk_) :: nc - nc = x%get_ncols() - call psb_realloc(n*nc,x%combuf,info) - end subroutine i_base_mlv_new_buffer - subroutine i_base_mlv_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine i_base_mlv_new_comid - - - subroutine i_base_mlv_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine i_base_mlv_maybe_free_buffer - - subroutine i_base_mlv_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine i_base_mlv_free_buffer - - subroutine i_base_mlv_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine i_base_mlv_free_comid + interface + module function i_base_mlv_use_buffer() result(res) + logical :: res + end function i_base_mlv_use_buffer + end interface + + interface + module subroutine i_base_mlv_new_buffer(n,x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_new_buffer + end interface + + interface + module subroutine i_base_mlv_new_comid(n,x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_new_comid + end interface + + interface + module subroutine i_base_mlv_maybe_free_buffer(x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_maybe_free_buffer + end interface + + interface + module subroutine i_base_mlv_free_buffer(x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_free_buffer + end interface + interface + module subroutine i_base_mlv_free_comid(x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine i_base_mlv_free_comid + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -2359,23 +1557,14 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine i_base_mlv_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: alpha, beta, y(:) - class(psb_i_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - call psi_gth(n,nc,idx,alpha,x%v,beta,y) - - end subroutine i_base_mlv_gthab + interface + module subroutine i_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_base_multivect_type) :: x + end subroutine i_base_mlv_gthab + end interface ! ! shortcut alpha=1 beta=0 ! @@ -2385,19 +1574,15 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i_base_mlv_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_ipk_) :: y(:) - class(psb_i_base_multivect_type) :: x - - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine i_base_mlv_gthzv_x + interface + module subroutine i_base_mlv_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_base_multivect_type) :: x + end subroutine i_base_mlv_gthzv_x + end interface ! ! shortcut alpha=1 beta=0 @@ -2408,24 +1593,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i_base_mlv_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: y(:) - class(psb_i_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine i_base_mlv_gthzv + interface + module subroutine i_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_base_multivect_type) :: x + end subroutine i_base_mlv_gthzv + end interface ! ! shortcut alpha=1 beta=0 ! @@ -2435,48 +1610,27 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine i_base_mlv_gthzm(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: y(:,:) - class(psb_i_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine i_base_mlv_gthzm + interface + module subroutine i_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:,:) + class(psb_i_base_multivect_type) :: x + end subroutine i_base_mlv_gthzm + end interface ! ! New comm internals impl. ! - subroutine i_base_mlv_gthzbuf(i,ixb,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, ixb - class(psb_i_base_vect_type) :: idx - class(psb_i_base_multivect_type) :: x - integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - nc = x%get_ncols() - call x%gth(n,idx%v(i:),x%combuf(ixb:)) - - end subroutine i_base_mlv_gthzbuf - + interface + module subroutine i_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_i_base_multivect_type) :: x + end subroutine i_base_mlv_gthzbuf + end interface + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -2490,72 +1644,43 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine i_base_mlv_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: beta, x(:) - class(psb_i_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = psb_size(y%v,2_psb_ipk_) - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine i_base_mlv_sctb - - subroutine i_base_mlv_sctbr2(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_ipk_) :: beta, x(:,:) - class(psb_i_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = y%get_ncols() - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine i_base_mlv_sctbr2 - - subroutine i_base_mlv_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer( psb_ipk_) :: beta, x(:) - class(psb_i_base_multivect_type) :: y - - call y%sct(n,idx%v(i:),x,beta) - - end subroutine i_base_mlv_sctb_x - - subroutine i_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, iyb - class(psb_i_base_vect_type) :: idx - integer(psb_ipk_) :: beta - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - nc = y%get_ncols() - call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) - call y%set_host() - - end subroutine i_base_mlv_sctb_buf + interface + module subroutine i_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_base_multivect_type) :: y + end subroutine i_base_mlv_sctb + end interface + + interface + module subroutine i_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:,:) + class(psb_i_base_multivect_type) :: y + end subroutine i_base_mlv_sctbr2 + end interface + + interface + module subroutine i_base_mlv_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_base_multivect_type) :: y + end subroutine i_base_mlv_sctb_x + end interface + + interface + module subroutine i_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta + class(psb_i_base_multivect_type) :: y + end subroutine i_base_mlv_sctb_buf + end interface ! !> Function base_device_wait: @@ -2563,9 +1688,43 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine i_base_mlv_device_wait() - implicit none + interface + module subroutine i_base_mlv_device_wait() + end subroutine i_base_mlv_device_wait + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_ipk_) :: x(:,:) + type(psb_i_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_i_base_multivect_type) :: this + integer(psb_ipk_) :: info - end subroutine i_base_mlv_device_wait + call this%asb(m,n,info) + + end function size_const end module psb_i_base_multivect_mod diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index c2b51668d..e7f44c011 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -110,7 +110,10 @@ module psb_i_vect_mod end type psb_i_vect_type - public :: psb_i_vect + public :: psb_i_vect, psb_i_vect_type,& + & psb_i_set_vect_default, psb_i_get_vect_default, & + & psb_i_clear_vect_default, psb_i_base_vect_type + private :: constructor, size_const interface psb_i_vect module procedure constructor, size_const @@ -132,180 +135,366 @@ module psb_i_vect_mod class(psb_i_base_vect_type), allocatable, target,& & save, private :: psb_i_base_vect_default - interface psb_set_vect_default - module procedure psb_i_set_vect_default - end interface psb_set_vect_default - - 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 + interface + module function i_vect_get_dupl(x) result(res) + 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 + 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 + 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 - 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 - +contains + 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 @@ -316,7 +505,6 @@ contains 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 @@ -325,7 +513,6 @@ contains 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) @@ -334,7 +521,6 @@ contains 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 @@ -345,150 +531,6 @@ contains 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) - - 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 - function constructor(x) result(this) integer(psb_ipk_) :: x(:) type(psb_i_vect_type) :: this @@ -510,296 +552,6 @@ 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 @@ -809,7 +561,6 @@ module psb_i_multivect_mod use psb_const_mod use psb_i_vect_mod - !private type psb_i_multivect_type @@ -854,71 +605,233 @@ module psb_i_multivect_mod end type psb_i_multivect_type public :: psb_i_multivect, psb_i_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default, & - & psb_i_base_multivect_type + & psb_i_set_multivect_default, psb_i_get_base_multivect_default, & + & psb_i_clear_multivect_default, psb_i_base_multivect_type - private interface psb_i_multivect module procedure constructor, size_const end interface psb_i_multivect + private + 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 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 + integer(psb_ipk_) :: info + 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 @@ -928,18 +841,16 @@ contains 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_multivect_default(v) result(res) +!!$ 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 @@ -950,85 +861,6 @@ contains 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) integer(psb_ipk_) :: x(:,:) type(psb_i_multivect_type) :: this @@ -1039,7 +871,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,222 +881,13 @@ 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 + + subroutine psb_i_clear_multivect_default() - 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) + if (allocated(psb_i_base_multivect_default)) then + deallocate(psb_i_base_multivect_default) end if - call move_alloc(tmp,x%v) - end subroutine i_mvect_cnv + end subroutine psb_i_clear_multivect_default end module psb_i_multivect_mod diff --git a/base/modules/serial/psb_l_base_vect_mod.F90 b/base/modules/serial/psb_l_base_vect_mod.F90 index 5be178a50..b429d309c 100644 --- a/base/modules/serial/psb_l_base_vect_mod.F90 +++ b/base/modules/serial/psb_l_base_vect_mod.F90 @@ -178,45 +178,12 @@ module psb_l_base_vect_mod end type psb_l_base_vect_type - public :: psb_l_base_vect + public :: psb_l_base_vect, psb_l_base_vect_type private :: constructor, size_const interface psb_l_base_vect module procedure constructor, size_const end interface psb_l_base_vect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - integer(psb_lpk_) :: x(:) - type(psb_l_base_vect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(n) result(this) - integer(psb_ipk_), intent(in) :: n - type(psb_l_base_vect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(n,info) - - end function size_const - ! ! Build from a sample ! @@ -226,36 +193,13 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine l_base_bld_x(x,this,scratch) - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: this(:) - class(psb_l_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - integer(psb_ipk_) :: i - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(size(this),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') - return - end if -#if defined (PSB_OPENMP) - !$omp parallel do private(i) - do i = 1, size(this) - x%v(i) = this(i) - end do -#else - x%v(:) = this(:) -#endif - end subroutine l_base_bld_x + interface + module subroutine l_base_bld_x(x,this,scratch) + integer(psb_lpk_), intent(in) :: this(:) + class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine l_base_bld_x + end interface ! ! Create with size, but no initialization @@ -266,50 +210,26 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine l_base_bld_mn(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_l_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine l_base_bld_mn - + interface + module subroutine l_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine l_base_bld_mn + end interface + !> Function bld_en: !! \memberof psb_l_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine l_base_bld_en(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_l_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine l_base_bld_en + interface + module subroutine l_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine l_base_bld_en + end interface !> Function base_all: !! \memberof psb_l_base_vect_type @@ -318,21 +238,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine l_base_all(n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_l_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine l_base_all + interface + module subroutine l_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_l_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_all + end interface !> Function base_mold: !! \memberof psb_l_base_vect_type @@ -340,42 +252,21 @@ contains !! \param y returned variable !! \param info return code !! - subroutine l_base_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(in) :: x - class(psb_l_base_vect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_l_base_vect_type :: y, stat=info) - - end subroutine l_base_mold - - subroutine l_base_reinit(x, info,clear) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - logical :: clear_ - - info = 0 - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - if (clear_) x%v(:) = lzero - call x%set_host() - call x%set_upd() - end if + interface + module subroutine l_base_mold(x, y, info) + class(psb_l_base_vect_type), intent(in) :: x + class(psb_l_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mold + end interface - end subroutine l_base_reinit + interface + module subroutine l_base_reinit(x, info,clear) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine l_base_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -404,152 +295,27 @@ contains !! \param info return code !! ! - subroutine l_base_ins_a(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_lpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine l_base_ins_a - - subroutine l_base_ins_v(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - class(psb_i_base_vect_type), intent(inout) :: irl - class(psb_l_base_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: isz - - info = 0 - if (psb_errstatus_fatal()) return - - if (irl%is_dev()) call irl%sync() - if (val%is_dev()) call val%sync() - if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,maxr,info) - - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine l_base_ins_v + interface + module subroutine l_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_ins_a + end interface + + + interface + module subroutine l_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_l_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_ins_v + end interface + ! @@ -558,18 +324,12 @@ contains !! \brief Zero out contents !! ! - subroutine l_base_zero(x) - use psi_serial_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x + interface + module subroutine l_base_zero(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_zero + end interface - if (allocated(x%v)) then - !$omp workshare - x%v(:)=lzero - !$omp end workshare - end if - call x%set_host() - end subroutine l_base_zero ! @@ -586,74 +346,15 @@ contains !! ! - subroutine l_base_asb_m(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_lpk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(n,vv,info) - vv(:) = lzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (vv(x%iv(i)).ne. lzero) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine l_base_asb_m + interface + module subroutine l_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine l_base_asb_m + end interface + ! ! Assembly. @@ -669,74 +370,15 @@ contains !! ! - subroutine l_base_asb_e(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_lpk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') - if (x%is_bld()) then - call psb_realloc(n,vv,info) - vv(:) = lzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne. lzero) then - call psb_errpush(psb_err_duplicate_coo,'vect_asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine l_base_asb_e + interface + module subroutine l_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine l_base_asb_e + end interface + ! !> Function base_free: @@ -746,22 +388,13 @@ contains !! \param info return code !! ! - subroutine l_base_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine l_base_free(x, info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_free + end interface - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - call x%set_null() - end subroutine l_base_free ! !> Function base_free_buffer: @@ -771,15 +404,13 @@ contains !! \param info return code !! ! - subroutine l_base_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine l_base_free_buffer(x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_free_buffer + end interface - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine l_base_free_buffer ! !> Function base_maybe_free_buffer: @@ -792,17 +423,13 @@ contains !! \param info return code !! ! - subroutine l_base_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine l_base_maybe_free_buffer(x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_maybe_free_buffer + end interface - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine l_base_maybe_free_buffer ! !> Function base_free_comid: @@ -812,113 +439,107 @@ contains !! \param info return code !! ! - subroutine l_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine l_base_free_comid - - function l_base_get_ncfs(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function l_base_get_ncfs - - function l_base_get_dupl(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function l_base_get_dupl - - function l_base_get_state(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function l_base_get_state - - function l_base_is_null(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function l_base_is_null - - function l_base_is_bld(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function l_base_is_bld - - function l_base_is_upd(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function l_base_is_upd - - function l_base_is_asb(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function l_base_is_asb - - subroutine l_base_set_ncfs(n,x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine l_base_set_ncfs - - subroutine l_base_set_dupl(n,x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine l_base_set_dupl - - subroutine l_base_set_state(n,x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine l_base_set_state - - subroutine l_base_set_null(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine l_base_set_null - - subroutine l_base_set_bld(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine l_base_set_bld - - subroutine l_base_set_upd(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine l_base_set_upd - - subroutine l_base_set_asb(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine l_base_set_asb + interface + module subroutine l_base_free_comid(x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_free_comid + end interface + + + interface + module function l_base_get_ncfs(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_get_ncfs + end interface + + interface + module function l_base_get_dupl(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_get_dupl + end interface + + interface + module function l_base_get_state(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_get_state + end interface + + interface + module function l_base_is_null(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + end function l_base_is_null + end interface + + interface + module function l_base_is_bld(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + end function l_base_is_bld + end interface + + interface + module function l_base_is_upd(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + end function l_base_is_upd + end interface + + interface + module function l_base_is_asb(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + end function l_base_is_asb + end interface + + interface + module subroutine l_base_set_ncfs(n,x) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine l_base_set_ncfs + end interface + + interface + module subroutine l_base_set_dupl(n,x) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine l_base_set_dupl + end interface + + interface + module subroutine l_base_set_state(n,x) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine l_base_set_state + end interface + + interface + module subroutine l_base_set_null(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_set_null + end interface + + interface + module subroutine l_base_set_bld(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_set_bld + end interface + + interface + module subroutine l_base_set_upd(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_set_upd + end interface + + interface + module subroutine l_base_set_asb(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -930,11 +551,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine l_base_sync(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - end subroutine l_base_sync + interface + module subroutine l_base_sync(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_sync + end interface ! !> Function base_set_host: @@ -942,11 +563,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine l_base_set_host(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - end subroutine l_base_set_host + interface + module subroutine l_base_set_host(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_set_host + end interface ! !> Function base_set_dev: @@ -954,11 +575,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine l_base_set_dev(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - end subroutine l_base_set_dev + interface + module subroutine l_base_set_dev(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_set_dev + end interface ! !> Function base_set_sync: @@ -966,11 +587,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine l_base_set_sync(x) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - - end subroutine l_base_set_sync + interface + module subroutine l_base_set_sync(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_set_sync + end interface ! !> Function base_is_dev: @@ -978,13 +599,12 @@ contains !! \brief Is vector on external device . !! ! - function l_base_is_dev(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - logical :: res - - res = .false. - end function l_base_is_dev + interface + module function l_base_is_dev(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + end function l_base_is_dev + end interface ! !> Function base_is_host @@ -992,13 +612,12 @@ contains !! \brief Is vector on standard memory . !! ! - function l_base_is_host(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function l_base_is_host + interface + module function l_base_is_host(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + end function l_base_is_host + end interface ! !> Function base_is_sync @@ -1006,32 +625,24 @@ contains !! \brief Is vector on sync . !! ! - function l_base_is_sync(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function l_base_is_sync + interface + module function l_base_is_sync(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + end function l_base_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine l_base_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(in) :: x - class(psb_l_base_vect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine l_base_cpy + interface + module subroutine l_base_cpy(x, y) + class(psb_l_base_vect_type), intent(in) :: x + class(psb_l_base_vect_type), intent(out) :: y + end subroutine l_base_cpy + end interface ! ! Size info. @@ -1042,15 +653,12 @@ contains !! \brief Number of entries !! ! - function l_base_get_nrows(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v) - - end function l_base_get_nrows + interface + module function l_base_get_nrows(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_get_nrows + end interface ! !> Function base_get_sizeof @@ -1058,15 +666,12 @@ contains !! \brief Size in bytes !! ! - function l_base_sizeof(x) result(res) - implicit none - class(psb_l_base_vect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() - - end function l_base_sizeof + interface + module function l_base_sizeof(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function l_base_sizeof + end interface ! !> Function base_get_fmt @@ -1074,12 +679,11 @@ contains !! \brief Format !! ! - function l_base_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function l_base_get_fmt - + interface + module function l_base_get_fmt() result(res) + character(len=5) :: res + end function l_base_get_fmt + end interface ! ! @@ -1089,34 +693,14 @@ contains !! \brief Extract a copy of the contents !! ! - function l_base_get_vect(x,n) result(res) - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_lpk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - ! Local variables - integer(psb_ipk_) :: isz, i - - if (.not.allocated(x%v)) return - if (.not.x%is_host()) call x%sync() - isz = x%get_nrows() - if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') - return - end if - if (.false.) then - res(1:isz) = x%v(1:isz) - else - !$omp parallel do private(i) - do i=1, isz - res(i) = x%v(i) - end do - end if - - end function l_base_get_vect - + interface + module function l_base_get_vect(x,n) result(res) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function l_base_get_vect + end interface + ! ! Reset all values ! @@ -1126,32 +710,13 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine l_base_set_scal(x,val,first,last) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i - - first_=1 - last_=size(x%v) - if (present(first)) first_ = max(1,first) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val - end do -#else - x%v(first_:last_) = val -#endif - call x%set_host() - - end subroutine l_base_set_scal - + interface + module subroutine l_base_set_scal(x,val,first,last) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine l_base_set_scal + end interface ! !> Function base_set_vect @@ -1159,45 +724,20 @@ contains !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine l_base_set_vect(x,val,first,last) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i, info - - if (.not.allocated(x%v)) then - call psb_realloc(size(val),x%v,info) - end if - - first_ = 1 - if (present(first)) first_ = max(1,first) - last_ = min(psb_size(x%v),first_+size(val)-1) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() - -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val(i-first_+1) - end do -#else - x%v(first_:last_) = val(1:last_-first_+1) -#endif - call x%set_host() - - end subroutine l_base_set_vect - - subroutine l_base_check_addr(x) - class(psb_l_base_vect_type), intent(inout) :: x - - write(0,*) 'Check addr: base version, do nothing' - - end subroutine l_base_check_addr - - + interface + module subroutine l_base_set_vect(x,val,first,last) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine l_base_set_vect + end interface + + interface + module subroutine l_base_check_addr(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_check_addr + end interface + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -1211,18 +751,15 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine l_base_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: alpha, beta, y(:) - class(psb_l_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,alpha,x%v,beta,y) - - end subroutine l_base_gthab + interface + module subroutine l_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_base_vect_type) :: x + end subroutine l_base_gthab + end interface + ! ! shortcut alpha=1 beta=0 ! @@ -1232,77 +769,60 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine l_base_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - integer(psb_lpk_) :: y(:) - class(psb_l_base_vect_type) :: x - - if (idx%is_dev()) call idx%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine l_base_gthzv_x - + interface + module subroutine l_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: y(:) + class(psb_l_base_vect_type) :: x + end subroutine l_base_gthzv_x + end interface + ! ! New comm internals impl. ! - subroutine l_base_gthzbuf(i,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - class(psb_l_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),x%combuf(i:)) - - end subroutine l_base_gthzbuf + interface + module subroutine l_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_l_base_vect_type) :: x + end subroutine l_base_gthzbuf + end interface + ! !> Function base_device_wait: !! \memberof psb_l_base_vect_type !! \brief device_wait: base version is a no-op. !! ! - subroutine l_base_device_wait() - implicit none - - end subroutine l_base_device_wait - - function l_base_use_buffer() result(res) - logical :: res - - res = .true. - end function l_base_use_buffer - - subroutine l_base_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%combuf,info) - end subroutine l_base_new_buffer - - subroutine l_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine l_base_new_comid + interface + module subroutine l_base_device_wait() + end subroutine l_base_device_wait + end interface + interface + module function l_base_use_buffer() result(res) + logical :: res + end function l_base_use_buffer + end interface + + interface + module subroutine l_base_new_buffer(n,x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_new_buffer + end interface + + interface + module subroutine l_base_new_comid(n,x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_new_comid + end interface ! ! shortcut alpha=1 beta=0 @@ -1313,18 +833,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine l_base_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: y(:) - class(psb_l_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,x%v,y) - - end subroutine l_base_gthzv + interface + module subroutine l_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_base_vect_type) :: x + end subroutine l_base_gthzv + end interface ! ! Scatter: @@ -1339,63 +855,73 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine l_base_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: beta, x(:) - class(psb_l_base_vect_type) :: y - - if (y%is_dev()) call y%sync() - call psi_sct(n,idx,x,beta,y%v) - call y%set_host() - - end subroutine l_base_sctb - - subroutine l_base_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_lpk_) :: beta, x(:) - class(psb_l_base_vect_type) :: y - - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),x,beta) - call y%set_host() - - end subroutine l_base_sctb_x - - subroutine l_base_sctb_buf(i,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_lpk_) :: beta - class(psb_l_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),y%combuf(i:),beta) - call y%set_host() - - end subroutine l_base_sctb_buf + interface + module subroutine l_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_base_vect_type) :: y + end subroutine l_base_sctb + end interface + + interface + module subroutine l_base_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_base_vect_type) :: y + end subroutine l_base_sctb_x + end interface + + interface + module subroutine l_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta + class(psb_l_base_vect_type) :: y + end subroutine l_base_sctb_buf + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_lpk_) :: x(:) + type(psb_l_base_vect_type) :: this + integer(psb_ipk_) :: info + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_l_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const end module psb_l_base_vect_mod module psb_l_base_multivect_mod - use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_l_base_vect_mod @@ -1410,8 +936,6 @@ module psb_l_base_multivect_mod !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private - public :: psb_l_base_multivect, psb_l_base_multivect_type type psb_l_base_multivect_type !> Values. @@ -1524,43 +1048,13 @@ module psb_l_base_multivect_mod generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_l_base_multivect_type + public :: psb_l_base_multivect, psb_l_base_multivect_type + interface psb_l_base_multivect module procedure constructor, size_const end interface psb_l_base_multivect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - integer(psb_lpk_) :: x(:,:) - type(psb_l_base_multivect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),& - & size(x,dim=2,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_l_base_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(m,n,info) - - end function size_const + private ! ! Build from a sample @@ -1571,21 +1065,14 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine l_base_mlv_bld_x(x,this) - use psb_realloc_mod - integer(psb_lpk_), intent(in) :: this(:,:) - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - - call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') - return - end if - x%v(:,:) = this(:,:) - - end subroutine l_base_mlv_bld_x - + interface + module subroutine l_base_mlv_bld_x(x,this) + integer(psb_lpk_), intent(in) :: this(:,:) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + end subroutine l_base_mlv_bld_x + end interface + ! ! Create with size, but no initialization ! @@ -1595,18 +1082,15 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine l_base_mlv_bld_n(x,m,n,scratch) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: m,n - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch=scratch) - - end subroutine l_base_mlv_bld_n - + interface + module subroutine l_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + end subroutine l_base_mlv_bld_n + end interface + !> Function base_mlv_all: !! \memberof psb_l_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1614,21 +1098,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine l_base_mlv_all(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_l_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(m,n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine l_base_mlv_all + interface + module subroutine l_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_all + end interface !> Function base_mlv_mold: !! \memberof psb_l_base_multivect_type @@ -1636,34 +1112,20 @@ contains !! \param y returned variable !! \param info return code !! - subroutine l_base_mlv_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - class(psb_l_base_multivect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_l_base_multivect_type :: y, stat=info) - - end subroutine l_base_mlv_mold - - subroutine l_base_mlv_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine l_base_mlv_mold(x, y, info) + class(psb_l_base_multivect_type), intent(in) :: x + class(psb_l_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_mold + end interface - info = 0 - if (allocated(x%v)) then - call x%sync() - x%v(:,:) = lzero - call x%set_host() - call x%set_upd() - end if - - end subroutine l_base_mlv_reinit + interface + module subroutine l_base_mlv_reinit(x, info) + class(psb_l_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -1692,129 +1154,15 @@ contains !! \param info return code !! ! - subroutine l_base_mlv_ins(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr - integer(psb_ipk_), intent(in) :: irl(:) - integer(psb_lpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - nc = size(x%v,2) - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_realloc(isz,nc,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k,:) = val(i,:) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_mlv_vect_ins') - return - end if - - end subroutine l_base_mlv_ins + interface + module subroutine l_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_ins + end interface ! !> Function base_mlv_zero @@ -1822,16 +1170,11 @@ contains !! \brief Zero out contents !! ! - subroutine l_base_mlv_zero(x) - use psi_serial_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) x%v=lzero - call x%set_host() - - end subroutine l_base_mlv_zero - + interface + module subroutine l_base_mlv_zero(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_zero + end interface ! ! Assembly. @@ -1846,81 +1189,15 @@ contains !! \param info return code !! ! - - subroutine l_base_mlv_asb(m,n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - integer(psb_lpk_), allocatable :: vv(:,:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(m,n,vv,info) - vv(:,:) = lzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i),:) = x%v(i,:) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (any(vv(x%iv(i),:).ne.lzero)) then - info = psb_err_duplicate_coo - call psb_errpush(info,'mvect-asb') - return - else - vv(x%iv(i),:) = x%v(i,:) - end if - end do - case default - write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: @@ -1930,118 +1207,106 @@ contains !! \param info return code !! ! - subroutine l_base_mlv_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - - end subroutine l_base_mlv_free - - function l_base_mlv_get_ncfs(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function l_base_mlv_get_ncfs - - function l_base_mlv_get_dupl(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function l_base_mlv_get_dupl - - function l_base_mlv_get_state(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function l_base_mlv_get_state - - function l_base_mlv_is_null(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function l_base_mlv_is_null - - function l_base_mlv_is_bld(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function l_base_mlv_is_bld - - function l_base_mlv_is_upd(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function l_base_mlv_is_upd - - function l_base_mlv_is_asb(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function l_base_mlv_is_asb - - subroutine l_base_mlv_set_ncfs(n,x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine l_base_mlv_set_ncfs - - subroutine l_base_mlv_set_dupl(n,x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine l_base_mlv_set_dupl - - subroutine l_base_mlv_set_state(n,x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine l_base_mlv_set_state - - subroutine l_base_mlv_set_null(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine l_base_mlv_set_null - - subroutine l_base_mlv_set_bld(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine l_base_mlv_set_bld - - subroutine l_base_mlv_set_upd(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine l_base_mlv_set_upd - - subroutine l_base_mlv_set_asb(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine l_base_mlv_set_asb - + interface + module subroutine l_base_mlv_free(x, info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_free + end interface + + interface + module function l_base_mlv_get_ncfs(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_mlv_get_ncfs + end interface + + interface + module function l_base_mlv_get_dupl(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_mlv_get_dupl + end interface + + interface + module function l_base_mlv_get_state(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_mlv_get_state + end interface + + interface + module function l_base_mlv_is_null(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + end function l_base_mlv_is_null + end interface + + interface + module function l_base_mlv_is_bld(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + end function l_base_mlv_is_bld + end interface + + interface + module function l_base_mlv_is_upd(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + end function l_base_mlv_is_upd + end interface + + interface + module function l_base_mlv_is_asb(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + end function l_base_mlv_is_asb + end interface + + interface + module subroutine l_base_mlv_set_ncfs(n,x) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine l_base_mlv_set_ncfs + end interface + + interface + module subroutine l_base_mlv_set_dupl(n,x) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine l_base_mlv_set_dupl + end interface + + interface + module subroutine l_base_mlv_set_state(n,x) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine l_base_mlv_set_state + end interface + + interface + module subroutine l_base_mlv_set_null(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_set_null + end interface + + interface + module subroutine l_base_mlv_set_bld(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_set_bld + end interface + + interface + module subroutine l_base_mlv_set_upd(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_set_upd + end interface + + interface + module subroutine l_base_mlv_set_asb(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -2053,11 +1318,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine l_base_mlv_sync(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - end subroutine l_base_mlv_sync + interface + module subroutine l_base_mlv_sync(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_sync + end interface ! !> Function base_mlv_set_host: @@ -2065,11 +1330,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine l_base_mlv_set_host(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - end subroutine l_base_mlv_set_host + interface + module subroutine l_base_mlv_set_host(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_set_host + end interface ! !> Function base_mlv_set_dev: @@ -2077,11 +1342,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine l_base_mlv_set_dev(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - end subroutine l_base_mlv_set_dev + interface + module subroutine l_base_mlv_set_dev(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_set_dev + end interface ! !> Function base_mlv_set_sync: @@ -2089,11 +1354,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine l_base_mlv_set_sync(x) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - - end subroutine l_base_mlv_set_sync + interface + module subroutine l_base_mlv_set_sync(x) + class(psb_l_base_multivect_type), intent(inout) :: x + end subroutine l_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -2101,13 +1366,12 @@ contains !! \brief Is vector on external device . !! ! - function l_base_mlv_is_dev(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - logical :: res - - res = .false. - end function l_base_mlv_is_dev + interface + module function l_base_mlv_is_dev(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + end function l_base_mlv_is_dev + end interface ! !> Function base_mlv_is_host @@ -2115,13 +1379,12 @@ contains !! \brief Is vector on standard memory . !! ! - function l_base_mlv_is_host(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function l_base_mlv_is_host + interface + module function l_base_mlv_is_host(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + end function l_base_mlv_is_host + end interface ! !> Function base_mlv_is_sync @@ -2129,35 +1392,25 @@ contains !! \brief Is vector on sync . !! ! - function l_base_mlv_is_sync(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function l_base_mlv_is_sync + interface + module function l_base_mlv_is_sync(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + end function l_base_mlv_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine l_base_mlv_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - class(psb_l_base_multivect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine l_base_mlv_cpy - + interface + module subroutine l_base_mlv_cpy(x, y) + class(psb_l_base_multivect_type), intent(in) :: x + class(psb_l_base_multivect_type), intent(out) :: y + end subroutine l_base_mlv_cpy + end interface - ! ! Size info. ! ! @@ -2166,25 +1419,19 @@ contains !! \brief Number of entries !! ! - function l_base_mlv_get_nrows(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function l_base_mlv_get_nrows + interface + module function l_base_mlv_get_nrows(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_mlv_get_nrows + end interface - function l_base_mlv_get_ncols(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,2) - - end function l_base_mlv_get_ncols + interface + module function l_base_mlv_get_ncols(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function l_base_mlv_get_ncols + end interface ! !> Function base_mlv_get_sizeof @@ -2192,15 +1439,12 @@ contains !! \brief Size in bytesa !! ! - function l_base_mlv_sizeof(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() * x%get_ncols() - - end function l_base_mlv_sizeof + interface + module function l_base_mlv_sizeof(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function l_base_mlv_sizeof + end interface ! !> Function base_mlv_get_fmt @@ -2208,12 +1452,11 @@ contains !! \brief Format !! ! - function l_base_mlv_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function l_base_mlv_get_fmt - + interface + module function l_base_mlv_get_fmt() result(res) + character(len=5) :: res + end function l_base_mlv_get_fmt + end interface ! ! @@ -2223,22 +1466,12 @@ contains !! \brief Extract a copy of the contents !! ! - function l_base_mlv_get_vect(x) result(res) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_lpk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info,m,n - m = x%get_nrows() - n = x%get_ncols() - if (.not.allocated(x%v)) return - call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') - return - end if - res(1:m,1:n) = x%v(1:m,1:n) - end function l_base_mlv_get_vect + interface + module function l_base_mlv_get_vect(x) result(res) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:,:) + end function l_base_mlv_get_vect + end interface ! ! Reset all values @@ -2249,104 +1482,69 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine l_base_mlv_set_scal(x,val) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val - - integer(psb_ipk_) :: info - x%v = val - - end subroutine l_base_mlv_set_scal - + interface + module subroutine l_base_mlv_set_scal(x,val) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + end subroutine l_base_mlv_set_scal + end interface + ! !> Function base_mlv_set_vect !! \memberof psb_l_base_multivect_type !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine l_base_mlv_set_vect(x,val) - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_lpk_), intent(in) :: val(:,:) - integer(psb_ipk_) :: nr, nc - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - nr = min(size(x%v,1),size(val,1)) - nc = min(size(x%v,2),size(val,2)) - - x%v(1:nr,1:nc) = val(1:nr,1:nc) - else - x%v = val - end if - - end subroutine l_base_mlv_set_vect - - - function l_base_mlv_use_buffer() result(res) - implicit none - logical :: res - - res = .true. - end function l_base_mlv_use_buffer - - subroutine l_base_mlv_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info + interface + module subroutine l_base_mlv_set_vect(x,val) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:,:) + end subroutine l_base_mlv_set_vect + end interface - integer(psb_ipk_) :: nc - nc = x%get_ncols() - call psb_realloc(n*nc,x%combuf,info) - end subroutine l_base_mlv_new_buffer - subroutine l_base_mlv_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine l_base_mlv_new_comid - - - subroutine l_base_mlv_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine l_base_mlv_maybe_free_buffer - - subroutine l_base_mlv_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine l_base_mlv_free_buffer - - subroutine l_base_mlv_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine l_base_mlv_free_comid + interface + module function l_base_mlv_use_buffer() result(res) + logical :: res + end function l_base_mlv_use_buffer + end interface + + interface + module subroutine l_base_mlv_new_buffer(n,x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_new_buffer + end interface + + interface + module subroutine l_base_mlv_new_comid(n,x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_new_comid + end interface + + interface + module subroutine l_base_mlv_maybe_free_buffer(x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_maybe_free_buffer + end interface + + interface + module subroutine l_base_mlv_free_buffer(x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_free_buffer + end interface + interface + module subroutine l_base_mlv_free_comid(x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine l_base_mlv_free_comid + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -2360,23 +1558,14 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine l_base_mlv_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: alpha, beta, y(:) - class(psb_l_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - call psi_gth(n,nc,idx,alpha,x%v,beta,y) - - end subroutine l_base_mlv_gthab + interface + module subroutine l_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_base_multivect_type) :: x + end subroutine l_base_mlv_gthab + end interface ! ! shortcut alpha=1 beta=0 ! @@ -2386,19 +1575,15 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine l_base_mlv_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer(psb_lpk_) :: y(:) - class(psb_l_base_multivect_type) :: x - - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine l_base_mlv_gthzv_x + interface + module subroutine l_base_mlv_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_base_multivect_type) :: x + end subroutine l_base_mlv_gthzv_x + end interface ! ! shortcut alpha=1 beta=0 @@ -2409,24 +1594,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine l_base_mlv_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: y(:) - class(psb_l_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine l_base_mlv_gthzv + interface + module subroutine l_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_base_multivect_type) :: x + end subroutine l_base_mlv_gthzv + end interface ! ! shortcut alpha=1 beta=0 ! @@ -2436,48 +1611,27 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine l_base_mlv_gthzm(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: y(:,:) - class(psb_l_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine l_base_mlv_gthzm + interface + module subroutine l_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:,:) + class(psb_l_base_multivect_type) :: x + end subroutine l_base_mlv_gthzm + end interface ! ! New comm internals impl. ! - subroutine l_base_mlv_gthzbuf(i,ixb,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, ixb - class(psb_i_base_vect_type) :: idx - class(psb_l_base_multivect_type) :: x - integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - nc = x%get_ncols() - call x%gth(n,idx%v(i:),x%combuf(ixb:)) - - end subroutine l_base_mlv_gthzbuf - + interface + module subroutine l_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_l_base_multivect_type) :: x + end subroutine l_base_mlv_gthzbuf + end interface + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -2491,72 +1645,43 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine l_base_mlv_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: beta, x(:) - class(psb_l_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = psb_size(y%v,2_psb_ipk_) - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine l_base_mlv_sctb - - subroutine l_base_mlv_sctbr2(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - integer(psb_lpk_) :: beta, x(:,:) - class(psb_l_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = y%get_ncols() - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine l_base_mlv_sctbr2 - - subroutine l_base_mlv_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - integer( psb_lpk_) :: beta, x(:) - class(psb_l_base_multivect_type) :: y - - call y%sct(n,idx%v(i:),x,beta) - - end subroutine l_base_mlv_sctb_x - - subroutine l_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, iyb - class(psb_i_base_vect_type) :: idx - integer(psb_lpk_) :: beta - class(psb_l_base_multivect_type) :: y - integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - nc = y%get_ncols() - call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) - call y%set_host() - - end subroutine l_base_mlv_sctb_buf + interface + module subroutine l_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_base_multivect_type) :: y + end subroutine l_base_mlv_sctb + end interface + + interface + module subroutine l_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:,:) + class(psb_l_base_multivect_type) :: y + end subroutine l_base_mlv_sctbr2 + end interface + + interface + module subroutine l_base_mlv_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_base_multivect_type) :: y + end subroutine l_base_mlv_sctb_x + end interface + + interface + module subroutine l_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta + class(psb_l_base_multivect_type) :: y + end subroutine l_base_mlv_sctb_buf + end interface ! !> Function base_device_wait: @@ -2564,9 +1689,43 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine l_base_mlv_device_wait() - implicit none + interface + module subroutine l_base_mlv_device_wait() + end subroutine l_base_mlv_device_wait + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_lpk_) :: x(:,:) + type(psb_l_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_l_base_multivect_type) :: this + integer(psb_ipk_) :: info - end subroutine l_base_mlv_device_wait + call this%asb(m,n,info) + + end function size_const end module psb_l_base_multivect_mod diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index 838251294..f46d55077 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -111,7 +111,10 @@ module psb_l_vect_mod end type psb_l_vect_type - public :: psb_l_vect + public :: psb_l_vect, psb_l_vect_type,& + & psb_l_set_vect_default, psb_l_get_vect_default, & + & psb_l_clear_vect_default, psb_l_base_vect_type + private :: constructor, size_const interface psb_l_vect module procedure constructor, size_const @@ -133,180 +136,366 @@ module psb_l_vect_mod class(psb_l_base_vect_type), allocatable, target,& & save, private :: psb_l_base_vect_default - interface psb_set_vect_default - module procedure psb_l_set_vect_default - end interface psb_set_vect_default - - 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 + interface + module function l_vect_get_dupl(x) result(res) + 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 + 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 + 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 - 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 - +contains + 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 @@ -317,7 +506,6 @@ contains 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 @@ -326,7 +514,6 @@ contains 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) @@ -335,7 +522,6 @@ contains 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 @@ -346,150 +532,6 @@ contains 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) - - 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 - function constructor(x) result(this) integer(psb_lpk_) :: x(:) type(psb_l_vect_type) :: this @@ -511,296 +553,6 @@ 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 @@ -810,7 +562,6 @@ module psb_l_multivect_mod use psb_const_mod use psb_i_vect_mod - !private type psb_l_multivect_type @@ -855,71 +606,233 @@ module psb_l_multivect_mod end type psb_l_multivect_type public :: psb_l_multivect, psb_l_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default, & - & psb_l_base_multivect_type + & psb_l_set_multivect_default, psb_l_get_base_multivect_default, & + & psb_l_clear_multivect_default, psb_l_base_multivect_type - private interface psb_l_multivect module procedure constructor, size_const end interface psb_l_multivect + private + 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 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 + integer(psb_ipk_) :: info + 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 @@ -929,18 +842,16 @@ contains 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_multivect_default(v) result(res) +!!$ 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 @@ -951,85 +862,6 @@ contains 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) integer(psb_lpk_) :: x(:,:) type(psb_l_multivect_type) :: this @@ -1040,7 +872,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,222 +882,13 @@ 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 + + subroutine psb_l_clear_multivect_default() - 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) + if (allocated(psb_l_base_multivect_default)) then + deallocate(psb_l_base_multivect_default) end if - call move_alloc(tmp,x%v) - end subroutine l_mvect_cnv + end subroutine psb_l_clear_multivect_default end module psb_l_multivect_mod diff --git a/base/modules/serial/psb_s_base_vect_mod.F90 b/base/modules/serial/psb_s_base_vect_mod.F90 index d8e88adab..07eda9577 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -253,45 +253,12 @@ module psb_s_base_vect_mod end type psb_s_base_vect_type - public :: psb_s_base_vect + public :: psb_s_base_vect, psb_s_base_vect_type private :: constructor, size_const interface psb_s_base_vect module procedure constructor, size_const end interface psb_s_base_vect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - real(psb_spk_) :: x(:) - type(psb_s_base_vect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(n) result(this) - integer(psb_ipk_), intent(in) :: n - type(psb_s_base_vect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(n,info) - - end function size_const - ! ! Build from a sample ! @@ -301,36 +268,13 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine s_base_bld_x(x,this,scratch) - use psb_realloc_mod - implicit none - real(psb_spk_), intent(in) :: this(:) - class(psb_s_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - integer(psb_ipk_) :: i - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(size(this),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') - return - end if -#if defined (PSB_OPENMP) - !$omp parallel do private(i) - do i = 1, size(this) - x%v(i) = this(i) - end do -#else - x%v(:) = this(:) -#endif - end subroutine s_base_bld_x + interface + module subroutine s_base_bld_x(x,this,scratch) + real(psb_spk_), intent(in) :: this(:) + class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine s_base_bld_x + end interface ! ! Create with size, but no initialization @@ -341,50 +285,26 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_bld_mn(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_s_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine s_base_bld_mn - + interface + module subroutine s_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine s_base_bld_mn + end interface + !> Function bld_en: !! \memberof psb_s_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_bld_en(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_s_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine s_base_bld_en + interface + module subroutine s_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine s_base_bld_en + end interface !> Function base_all: !! \memberof psb_s_base_vect_type @@ -393,21 +313,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine s_base_all(n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_s_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine s_base_all + interface + module subroutine s_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_s_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_all + end interface !> Function base_mold: !! \memberof psb_s_base_vect_type @@ -415,42 +327,21 @@ contains !! \param y returned variable !! \param info return code !! - subroutine s_base_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(in) :: x - class(psb_s_base_vect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_s_base_vect_type :: y, stat=info) - - end subroutine s_base_mold - - subroutine s_base_reinit(x, info,clear) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - logical :: clear_ - - info = 0 - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - if (clear_) x%v(:) = szero - call x%set_host() - call x%set_upd() - end if - - end subroutine s_base_reinit + interface + module subroutine s_base_mold(x, y, info) + class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mold + end interface + + interface + module subroutine s_base_reinit(x, info,clear) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine s_base_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -479,152 +370,27 @@ contains !! \param info return code !! ! - subroutine s_base_ins_a(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine s_base_ins_a - - subroutine s_base_ins_v(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - class(psb_i_base_vect_type), intent(inout) :: irl - class(psb_s_base_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: isz - - info = 0 - if (psb_errstatus_fatal()) return - - if (irl%is_dev()) call irl%sync() - if (val%is_dev()) call val%sync() - if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,maxr,info) - - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine s_base_ins_v + interface + module subroutine s_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_ins_a + end interface + + + interface + module subroutine s_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_s_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_ins_v + end interface + ! @@ -633,18 +399,12 @@ contains !! \brief Zero out contents !! ! - subroutine s_base_zero(x) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x + interface + module subroutine s_base_zero(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_zero + end interface - if (allocated(x%v)) then - !$omp workshare - x%v(:)=szero - !$omp end workshare - end if - call x%set_host() - end subroutine s_base_zero ! @@ -661,74 +421,15 @@ contains !! ! - subroutine s_base_asb_m(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - real(psb_spk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(n,vv,info) - vv(:) = szero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (vv(x%iv(i)).ne. szero) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine s_base_asb_m + interface + module subroutine s_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine s_base_asb_m + end interface + ! ! Assembly. @@ -744,74 +445,15 @@ contains !! ! - subroutine s_base_asb_e(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - real(psb_spk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') - if (x%is_bld()) then - call psb_realloc(n,vv,info) - vv(:) = szero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne. szero) then - call psb_errpush(psb_err_duplicate_coo,'vect_asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine s_base_asb_e + interface + module subroutine s_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine s_base_asb_e + end interface + ! !> Function base_free: @@ -821,22 +463,13 @@ contains !! \param info return code !! ! - subroutine s_base_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine s_base_free(x, info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_free + end interface - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - call x%set_null() - end subroutine s_base_free ! !> Function base_free_buffer: @@ -846,15 +479,13 @@ contains !! \param info return code !! ! - subroutine s_base_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine s_base_free_buffer(x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_free_buffer + end interface - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine s_base_free_buffer ! !> Function base_maybe_free_buffer: @@ -867,17 +498,13 @@ contains !! \param info return code !! ! - subroutine s_base_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine s_base_maybe_free_buffer(x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_maybe_free_buffer + end interface - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine s_base_maybe_free_buffer ! !> Function base_free_comid: @@ -887,113 +514,107 @@ contains !! \param info return code !! ! - subroutine s_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine s_base_free_comid - - function s_base_get_ncfs(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function s_base_get_ncfs - - function s_base_get_dupl(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function s_base_get_dupl - - function s_base_get_state(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function s_base_get_state - - function s_base_is_null(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function s_base_is_null - - function s_base_is_bld(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function s_base_is_bld - - function s_base_is_upd(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function s_base_is_upd - - function s_base_is_asb(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function s_base_is_asb - - subroutine s_base_set_ncfs(n,x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine s_base_set_ncfs - - subroutine s_base_set_dupl(n,x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine s_base_set_dupl - - subroutine s_base_set_state(n,x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine s_base_set_state - - subroutine s_base_set_null(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine s_base_set_null - - subroutine s_base_set_bld(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine s_base_set_bld - - subroutine s_base_set_upd(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine s_base_set_upd - - subroutine s_base_set_asb(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine s_base_set_asb + interface + module subroutine s_base_free_comid(x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_free_comid + end interface + + + interface + module function s_base_get_ncfs(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_get_ncfs + end interface + + interface + module function s_base_get_dupl(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_get_dupl + end interface + + interface + module function s_base_get_state(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_get_state + end interface + + interface + module function s_base_is_null(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + end function s_base_is_null + end interface + + interface + module function s_base_is_bld(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + end function s_base_is_bld + end interface + + interface + module function s_base_is_upd(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + end function s_base_is_upd + end interface + + interface + module function s_base_is_asb(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + end function s_base_is_asb + end interface + + interface + module subroutine s_base_set_ncfs(n,x) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine s_base_set_ncfs + end interface + + interface + module subroutine s_base_set_dupl(n,x) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine s_base_set_dupl + end interface + + interface + module subroutine s_base_set_state(n,x) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine s_base_set_state + end interface + + interface + module subroutine s_base_set_null(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_set_null + end interface + + interface + module subroutine s_base_set_bld(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_set_bld + end interface + + interface + module subroutine s_base_set_upd(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_set_upd + end interface + + interface + module subroutine s_base_set_asb(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -1005,11 +626,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine s_base_sync(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - end subroutine s_base_sync + interface + module subroutine s_base_sync(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_sync + end interface ! !> Function base_set_host: @@ -1017,11 +638,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine s_base_set_host(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - end subroutine s_base_set_host + interface + module subroutine s_base_set_host(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_set_host + end interface ! !> Function base_set_dev: @@ -1029,11 +650,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine s_base_set_dev(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - end subroutine s_base_set_dev + interface + module subroutine s_base_set_dev(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_set_dev + end interface ! !> Function base_set_sync: @@ -1041,11 +662,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine s_base_set_sync(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - end subroutine s_base_set_sync + interface + module subroutine s_base_set_sync(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_set_sync + end interface ! !> Function base_is_dev: @@ -1053,13 +674,12 @@ contains !! \brief Is vector on external device . !! ! - function s_base_is_dev(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - logical :: res - - res = .false. - end function s_base_is_dev + interface + module function s_base_is_dev(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + end function s_base_is_dev + end interface ! !> Function base_is_host @@ -1067,13 +687,12 @@ contains !! \brief Is vector on standard memory . !! ! - function s_base_is_host(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function s_base_is_host + interface + module function s_base_is_host(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + end function s_base_is_host + end interface ! !> Function base_is_sync @@ -1081,32 +700,24 @@ contains !! \brief Is vector on sync . !! ! - function s_base_is_sync(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function s_base_is_sync + interface + module function s_base_is_sync(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + end function s_base_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine s_base_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(in) :: x - class(psb_s_base_vect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine s_base_cpy + interface + module subroutine s_base_cpy(x, y) + class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(out) :: y + end subroutine s_base_cpy + end interface ! ! Size info. @@ -1117,15 +728,12 @@ contains !! \brief Number of entries !! ! - function s_base_get_nrows(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v) - - end function s_base_get_nrows + interface + module function s_base_get_nrows(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_get_nrows + end interface ! !> Function base_get_sizeof @@ -1133,15 +741,12 @@ contains !! \brief Size in bytes !! ! - function s_base_sizeof(x) result(res) - implicit none - class(psb_s_base_vect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() - - end function s_base_sizeof + interface + module function s_base_sizeof(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function s_base_sizeof + end interface ! !> Function base_get_fmt @@ -1149,12 +754,11 @@ contains !! \brief Format !! ! - function s_base_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function s_base_get_fmt - + interface + module function s_base_get_fmt() result(res) + character(len=5) :: res + end function s_base_get_fmt + end interface ! ! @@ -1164,34 +768,14 @@ contains !! \brief Extract a copy of the contents !! ! - function s_base_get_vect(x,n) result(res) - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - ! Local variables - integer(psb_ipk_) :: isz, i - - if (.not.allocated(x%v)) return - if (.not.x%is_host()) call x%sync() - isz = x%get_nrows() - if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') - return - end if - if (.false.) then - res(1:isz) = x%v(1:isz) - else - !$omp parallel do private(i) - do i=1, isz - res(i) = x%v(i) - end do - end if - - end function s_base_get_vect - + interface + module function s_base_get_vect(x,n) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function s_base_get_vect + end interface + ! ! Reset all values ! @@ -1201,32 +785,13 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine s_base_set_scal(x,val,first,last) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i - - first_=1 - last_=size(x%v) - if (present(first)) first_ = max(1,first) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val - end do -#else - x%v(first_:last_) = val -#endif - call x%set_host() - - end subroutine s_base_set_scal - + interface + module subroutine s_base_set_scal(x,val,first,last) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine s_base_set_scal + end interface ! !> Function base_set_vect @@ -1234,45 +799,20 @@ contains !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine s_base_set_vect(x,val,first,last) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i, info - - if (.not.allocated(x%v)) then - call psb_realloc(size(val),x%v,info) - end if - - first_ = 1 - if (present(first)) first_ = max(1,first) - last_ = min(psb_size(x%v),first_+size(val)-1) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() - -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val(i-first_+1) - end do -#else - x%v(first_:last_) = val(1:last_-first_+1) -#endif - call x%set_host() - - end subroutine s_base_set_vect - - subroutine s_base_check_addr(x) - class(psb_s_base_vect_type), intent(inout) :: x - - write(0,*) 'Check addr: base version, do nothing' - - end subroutine s_base_check_addr - - + interface + module subroutine s_base_set_vect(x,val,first,last) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine s_base_set_vect + end interface + + interface + module subroutine s_base_check_addr(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_check_addr + end interface + ! ! Get entry. ! @@ -1282,33 +822,22 @@ contains !! \brief Get one entry from the vector !! ! - function s_base_get_entry(x, index) result(res) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_spk_) :: res - - res = szero - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - res = x%v(index) - end if - - end function s_base_get_entry - - subroutine s_base_set_entry(x, index, val) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_spk_) :: val - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v(index) =val - call x%set_host() - end if - end subroutine s_base_set_entry - + interface + module function s_base_get_entry(x, index) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: res + end function s_base_get_entry + end interface + + interface + module subroutine s_base_set_entry(x, index, val) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + end subroutine s_base_set_entry + end interface + ! ! Overwrite with absolute value ! @@ -1317,40 +846,19 @@ contains !! \memberof psb_s_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine s_base_absval1(x) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: i - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1, size(x%v) - x%v(i) = abs(x%v(i)) - end do -#else - x%v = abs(x%v) -#endif - call x%set_host() - end if - - end subroutine s_base_absval1 - - subroutine s_base_absval2(x,y) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_) :: info - if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then - call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) - call y%absval() - end if - - end subroutine s_base_absval2 - + interface + module subroutine s_base_absval1(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_absval1 + end interface + + interface + module subroutine s_base_absval2(x,y) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + end subroutine s_base_absval2 + end interface + ! ! Dot products ! @@ -1361,29 +869,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_vect) to be multiplied by !! - function s_base_dot_v(n,x,y) result(res) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - real(psb_spk_), external :: sdot - - res = szero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_s_base_vect. - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_s_base_vect_type) - res = sdot(n,x%v,1,y%v,1) - class default - res = y%dot(n,x%v) - end select - - end function s_base_dot_v + interface + module function s_base_dot_v(n,x,y) result(res) + class(psb_s_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function + end interface ! ! Base workhorse is good old BLAS1 @@ -1395,17 +887,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function s_base_dot_a(n,x,y) result(res) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - real(psb_spk_), external :: sdot - - res = sdot(n,y,1,x%v,1) - - end function s_base_dot_a + interface + module function s_base_dot_a(n,x,y) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_base_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1421,20 +910,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine s_base_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call y%axpby(m,alpha,x%v,beta,info) - - end subroutine s_base_axpby_v + interface + module subroutine s_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_axpby_v + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1452,21 +936,16 @@ contains !! \param z The class(base_vect) to be returned !! \param info return code !! - subroutine s_base_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - class(psb_s_base_vect_type), intent(inout) :: z - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call z%axpby(m,alpha,x%v,beta,y%v,info) - - end subroutine s_base_axpby_v2 + interface + module subroutine s_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_axpby_v2 + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1481,20 +960,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine s_base_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_base_vect_type), intent(inout) :: y - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (y%is_dev()) call y%sync() - call psb_geaxpby(m,alpha,x,beta,y%v,info) - call y%set_host() - - end subroutine s_base_axpby_a + interface + module subroutine s_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_axpby_a + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1510,21 +984,16 @@ contains !! \param y(:) The array to be added !! \param info return code !! - subroutine s_base_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_base_vect_type), intent(inout) :: z - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (z%is_dev()) call z%sync() - call psb_geaxpby(m,alpha,x,beta,y,z%v,info) - call z%set_host() - - end subroutine s_base_axpby_a2 + interface + module subroutine s_base_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_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_axpby_a2 + end interface ! ! UPD_XYZ is invoked via Z, hence the structure below. @@ -1543,48 +1012,29 @@ contains !! \param z The class(base_vect) to be added !! \param info return code !! - subroutine s_base_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_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - class(psb_s_base_vect_type), intent(inout) :: z - real(psb_spk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(alpha/=szero)) call x%sync() - if (y%is_dev().and.(beta/=szero)) call y%sync() - if (z%is_dev().and.(delta/=szero)) call z%sync() - call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) - call y%set_host() - call z%set_host() - - end subroutine s_base_upd_xyz - - subroutine s_base_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_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - class(psb_s_base_vect_type), intent(inout) :: z - class(psb_s_base_vect_type), intent(inout) :: w - real(psb_spk_), intent (in) :: a,b,c,d,e,f - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(a/=szero)) call x%sync() - if (y%is_dev().and.(b/=szero)) call y%sync() - if (z%is_dev().and.(d/=szero)) call z%sync() - if (w%is_dev().and.(f/=szero)) call w%sync() - call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) - call y%set_host() - call z%set_host() - call w%set_host() - - end subroutine s_base_xyzw - - + interface + module subroutine s_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_upd_xyz + end interface + + interface + module subroutine s_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + class(psb_s_base_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_base_xyzw + end interface + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -1600,20 +1050,14 @@ contains !! \param x The class(base_vect) to be multiplied by !! \param info return code !! - subroutine s_base_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine s_base_mlt_v - + interface + module subroutine s_base_mlt_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlt_v + end interface + ! !> Function base_mlt_a !! \memberof psb_s_base_vect_type @@ -1621,25 +1065,13 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine s_base_mlt_a(x, y, info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: x(:) - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)*x(i) - end do - call y%set_host() - - end subroutine s_base_mlt_a - + interface + module subroutine s_base_mlt_a(x, y, info) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlt_a + end interface ! !> Function base_mlt_a_2 @@ -1652,87 +1084,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine s_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(z%v), size(x), size(y)) - if (alpha == szero) then - if (beta == sone) then - return - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - end do - end if - else - if (alpha == sone) then - if (beta == szero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = y(i)*x(i) - end do - else if (beta == sone) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) + y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) + y(i)*x(i) - end do - end if - else if (alpha == -sone) then - if (beta == szero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = -y(i)*x(i) - end do - else if (beta == sone) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) - y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - y(i)*x(i) - end do - end if - else - if (beta == szero) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = alpha*y(i)*x(i) - end do - else if (beta == sone) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = z%v(i) + alpha*y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(alpha, beta) - do i=1, n - z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) - end do - end if - end if - end if - call z%set_host() - - end subroutine s_base_mlt_a_2 - + interface + module subroutine s_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlt_a_2 + end interface + ! !> Function base_mlt_v_2 !! \memberof psb_s_base_vect_type @@ -1744,68 +1105,37 @@ contains !! \param y The class(base_vect) to be multiplied by !! \param info return code !! - subroutine s_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - real(psb_spk_), intent(in) :: alpha,beta - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (y%is_dev()) call y%sync() - if (x%is_dev()) call x%sync() - if (.not.psb_s_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - end if - end subroutine s_base_mlt_v_2 - - subroutine s_base_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_base_vect_type), intent(inout) :: y - class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call z%mlt(alpha,x,y%v,beta,info) - - end subroutine s_base_mlt_av - - subroutine s_base_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_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call z%mlt(alpha,y,x,beta,info) - - end subroutine s_base_mlt_va + interface + module subroutine s_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_spk_), intent(in) :: alpha,beta + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine s_base_mlt_v_2 + end interface + + interface + module subroutine s_base_mlt_av(alpha,x,y,beta,z,info) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlt_av + end interface + + interface + module subroutine s_base_mlt_va(alpha,x,y,beta,z,info) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: y(:) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlt_va + end interface + ! !> Function base_div_v !! \memberof psb_s_base_vect_type @@ -1813,38 +1143,22 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine s_base_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%div(x%v,info) - - end subroutine s_base_div_v - - subroutine s_base_div_a(x, y, info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: x(:) - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)/x(i) - end do - call y%set_host() - - end subroutine s_base_div_a + interface + module subroutine s_base_div_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_div_v + end interface + + interface + module subroutine s_base_div_a(x, y, info) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_div_a + end interface + ! !> Function base_div_v2 !! \memberof psb_s_base_vect_type @@ -1852,21 +1166,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine s_base_div_v2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call z%div(x%v,y%v,info) - call z%set_host() - end subroutine s_base_div_v2 + interface + module subroutine s_base_div_v2(x, y, z, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_div_v2 + end interface + ! !> Function base_div_v_check !! \memberof psb_s_base_vect_type @@ -1874,21 +1182,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine s_base_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call x%div(x%v,y%v,info,flag) - - end subroutine s_base_div_v_check + interface + module subroutine s_base_div_v_check(x, y, info, flag) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_base_div_v_check + end interface + ! !> Function base_div_v2_check !! \memberof psb_s_base_vect_type @@ -1896,21 +1198,16 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine s_base_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info,flag) - - end subroutine s_base_div_v2_check + interface + module subroutine s_base_div_v2_check(x, y, z, info, flag) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_base_div_v2_check + end interface + ! !> Function base_div_a2 !! \memberof psb_s_base_vect_type @@ -1918,25 +1215,15 @@ contains !! \param y(:) The array to be divided by !! \param info return code !! - subroutine s_base_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: z - real(psb_spk_), intent(in) :: x(:) - real(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - !$omp parallel do private(i) - do i=1, n - z%v(i) = x(i)/y(i) - end do - - end subroutine s_base_div_a2 + interface + module subroutine s_base_div_a2(x, y, z, info) + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_div_a2 + end interface + ! !> Function base_div_a2_check !! \memberof psb_s_base_vect_type @@ -1945,35 +1232,16 @@ contains !! \param y(:) The array to be dived by !! \param info return code !! - subroutine s_base_div_a2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: z - real(psb_spk_), intent(in) :: x(:) - real(psb_spk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call s_base_div_a2(x, y, z, info) - else - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - ! $omp parallel do private(i) - do i=1, n - if (y(i) /= 0) then - z%v(i) = x(i)/y(i) - else - info = 1 - exit - end if - end do - end if - - end subroutine s_base_div_a2_check + interface + module subroutine s_base_div_a2_check(x, y, z, info, flag) + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_base_div_a2_check + end interface + ! !> Function base_inv_v !! \memberof psb_s_base_vect_type @@ -1981,20 +1249,14 @@ contains !! \param x The vector to be inverted !! \param y The vector containing the inverted vector !! \param info return code - subroutine s_base_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info) - - - end subroutine s_base_inv_v + interface + module subroutine s_base_inv_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_inv_v + end interface + ! !> Function base_inv_v_check !! \memberof psb_s_base_vect_type @@ -2003,20 +1265,16 @@ contains !! \param y The vector containing the inverted vector !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v - subroutine s_base_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info,flag) - - end subroutine s_base_inv_v_check + interface + module subroutine s_base_inv_v_check(x, y, info, flag) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + end subroutine s_base_inv_v_check + end interface + ! !> Function base_inv_a2 !! \memberof psb_s_base_vect_type @@ -2025,24 +1283,14 @@ contains !! \param y The vector containing the inverted vector !! \param info return code ! - subroutine s_base_inv_a2(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: y - real(psb_spk_), intent(in) :: x(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - y%v(i) = 1_psb_spk_/x(i) - end do - - end subroutine s_base_inv_a2 + interface + module subroutine s_base_inv_a2(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_inv_a2 + end interface + ! !> Function base_inv_a2_check !! \memberof psb_s_base_vect_type @@ -2052,35 +1300,14 @@ contains !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v ! - subroutine s_base_inv_a2_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: y - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call s_base_inv_a2(x, y, info) - else - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - if (x(i) /= 0) then - y%v(i) = 1_psb_spk_/x(i) - else - info = 1 - y%v(i) = 0_psb_spk_ - end if - end do - end if - - - end subroutine s_base_inv_a2_check + interface + module subroutine s_base_inv_a2_check(x, y, info, flag) + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine s_base_inv_a2_check + end interface ! !> Function base_inv_a2_check @@ -2091,29 +1318,15 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine s_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() - - n = size(x) - !$omp parallel do private(i) - do i = 1, n, 1 - if ( abs(x(i)).ge.c ) then - z%v(i) = 1_psb_spk_ - else - z%v(i) = 0_psb_spk_ - end if - end do - info = 0 - - end subroutine s_base_acmp_a2 + interface + module subroutine s_base_acmp_a2(x,c,z,info) + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_acmp_a2 + end interface + ! !> Function base_cmp_v2 !! \memberof psb_s_base_vect_type @@ -2123,18 +1336,14 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine s_base_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: c - class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%acmp(x%v,c,info) - end subroutine s_base_acmp_v2 + interface + module subroutine s_base_acmp_v2(x,c,z,info) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_acmp_v2 + end interface ! ! Simple scaling @@ -2144,25 +1353,12 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine s_base_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), intent (in) :: alpha - integer(psb_ipk_) :: i - - if (allocated(x%v)) then -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1,size(x%v) - x%v(i) = alpha*x%v(i) - end do -#else - x%v = alpha*x%v -#endif - end if - call x%set_host() - end subroutine s_base_scal + interface + module subroutine s_base_scal(alpha, x) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent (in) :: alpha + end subroutine s_base_scal + end interface ! ! Norms 1, 2 and infinity @@ -2171,69 +1367,39 @@ contains !! \memberof psb_s_base_vect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function s_base_nrm2(n,x) result(res) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - real(psb_spk_), external :: snrm2 - - if (x%is_dev()) call x%sync() - res = snrm2(n,x%v,1) - - end function s_base_nrm2 + interface + module function s_base_nrm2(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_base_nrm2 + end interface ! !> Function base_amax !! \memberof psb_s_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function s_base_amax(n,x) result(res) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res = szero - !$omp parallel do private(i) reduction(max: res) - do i=1, n - res = max(res,abs(x%v(i))) - end do -#else - res = maxval(abs(x%v(1:n))) -#endif - end function s_base_amax + interface + module function s_base_amax(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_base_amax + end interface ! !> Function base_min !! \memberof psb_s_base_vect_type !! \brief min x(1:n) !! \param n how many entries to consider - function s_base_min(n,x) result(res) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res = HUGE(sone) - !$omp parallel do private(i) reduction(min: res) - do i=1, n - res = min(res,abs(x%v(i))) - end do -#else - ! - ! From M&R&C: if the array is of size zero, MINVAL - ! returns the largest positive value - ! - res = minval(x%v(1:n)) -#endif - end function s_base_min + interface + module function s_base_min(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_base_min + end interface ! !> Function base_minquotient_v @@ -2243,21 +1409,14 @@ contains !! \param y The denumerator vector !! \param info return code !! - function s_base_minquotient_v(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - real(psb_spk_) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - - z = x%minquotient(y%v,info) - - end function s_base_minquotient_v + interface + module function s_base_minquotient_v(x, y, info) result(z) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + end function s_base_minquotient_v + end interface ! !> Function base_minquotient_a2 @@ -2267,55 +1426,27 @@ contains !! \param y The denumerator array !! \param info return code !! - function s_base_minquotient_a2(x, y, info) result(z) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: y(:) - real(psb_spk_) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - real(psb_spk_) :: temp - - info = 0 - - z = huge(z) - n = min(size(y), size(x%v)) - !$omp parallel do private(i,temp) reduction(min: z) - do i=1, n - if ( y(i) /= szero ) then - temp = x%v(i)/y(i) - z = min(z,temp) - end if - end do - - end function s_base_minquotient_a2 - - + interface + module function s_base_minquotient_a2(x, y, info) result(z) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + end function s_base_minquotient_a2 + end interface + ! !> Function base_asum !! \memberof psb_s_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function s_base_asum(n,x) result(res) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res=szero - !$omp parallel do private(i) reduction(+: res) - do i= 1, size(x%v) - res = res + abs(x%v(i)) - end do -#else - res = sum(abs(x%v(1:n))) -#endif - end function s_base_asum - + interface + module function s_base_asum(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + end function s_base_asum + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -2329,18 +1460,15 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine s_base_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: alpha, beta, y(:) - class(psb_s_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,alpha,x%v,beta,y) - - end subroutine s_base_gthab + interface + module subroutine s_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_base_vect_type) :: x + end subroutine s_base_gthab + end interface + ! ! shortcut alpha=1 beta=0 ! @@ -2350,77 +1478,60 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine s_base_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - real(psb_spk_) :: y(:) - class(psb_s_base_vect_type) :: x - - if (idx%is_dev()) call idx%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine s_base_gthzv_x - + interface + module subroutine s_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: y(:) + class(psb_s_base_vect_type) :: x + end subroutine s_base_gthzv_x + end interface + ! ! New comm internals impl. ! - subroutine s_base_gthzbuf(i,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - class(psb_s_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),x%combuf(i:)) - - end subroutine s_base_gthzbuf + interface + module subroutine s_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_s_base_vect_type) :: x + end subroutine s_base_gthzbuf + end interface + ! !> Function base_device_wait: !! \memberof psb_s_base_vect_type !! \brief device_wait: base version is a no-op. !! ! - subroutine s_base_device_wait() - implicit none - - end subroutine s_base_device_wait - - function s_base_use_buffer() result(res) - logical :: res - - res = .true. - end function s_base_use_buffer - - subroutine s_base_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%combuf,info) - end subroutine s_base_new_buffer - - subroutine s_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine s_base_new_comid + interface + module subroutine s_base_device_wait() + end subroutine s_base_device_wait + end interface + interface + module function s_base_use_buffer() result(res) + logical :: res + end function s_base_use_buffer + end interface + + interface + module subroutine s_base_new_buffer(n,x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_new_buffer + end interface + + interface + module subroutine s_base_new_comid(n,x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_new_comid + end interface ! ! shortcut alpha=1 beta=0 @@ -2431,18 +1542,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine s_base_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: y(:) - class(psb_s_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,x%v,y) - - end subroutine s_base_gthzv + interface + module subroutine s_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_base_vect_type) :: x + end subroutine s_base_gthzv + end interface ! ! Scatter: @@ -2457,56 +1564,35 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine s_base_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: beta, x(:) - class(psb_s_base_vect_type) :: y - - if (y%is_dev()) call y%sync() - call psi_sct(n,idx,x,beta,y%v) - call y%set_host() - - end subroutine s_base_sctb - - subroutine s_base_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_spk_) :: beta, x(:) - class(psb_s_base_vect_type) :: y - - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),x,beta) - call y%set_host() - - end subroutine s_base_sctb_x - - subroutine s_base_sctb_buf(i,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_spk_) :: beta - class(psb_s_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),y%combuf(i:),beta) - call y%set_host() - - end subroutine s_base_sctb_buf - + interface + module subroutine s_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_base_vect_type) :: y + end subroutine s_base_sctb + end interface + + interface + module subroutine s_base_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_base_vect_type) :: y + end subroutine s_base_sctb_x + end interface + + interface + module subroutine s_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta + class(psb_s_base_vect_type) :: y + end subroutine s_base_sctb_buf + end interface + ! !> Function base_mask_a !! \memberof psb_s_base_vect_type @@ -2520,56 +1606,16 @@ contains !! \param t logical resulting from an and operation on all the tests !! \param info return code ! - subroutine s_base_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(:) - class(psb_s_base_vect_type), intent(inout) :: m - integer(psb_ipk_), intent(out) :: info - logical, intent(out) :: t - integer(psb_ipk_) :: i, n - - if (m%is_dev()) call m%sync() - t = .true. - - n = size(x) - do i = 1, n, 1 - if (c(i).eq.2_psb_spk_) then - if ( x(i) > szero ) then - m%v(i) = 0_psb_spk_ - else - m%v(i) = 1_psb_spk_ - t = .false. - end if - elseif (c(i).eq.1_psb_spk_) then - if ( x(i) >= szero ) then - m%v(i) = 0_psb_spk_ - else - m%v(i) = 1_psb_spk_ - t = .false. - end if - elseif (c(i).eq.-1_psb_spk_) then - if ( x(i) <= szero ) then - m%v(i) = 0_psb_spk_ - else - m%v(i) = 1_psb_spk_ - t = .false. - end if - elseif (c(i).eq.-2_psb_spk_) then - if ( x(i) < szero ) then - m%v(i) = 0_psb_spk_ - else - m%v(i) = 1_psb_spk_ - t = .false. - end if - else - m%v(i) = 0_psb_spk_ - end if - end do - info = 0 - - end subroutine s_base_mask_a + interface + module subroutine s_base_mask_a(c,x,m,t,info) + real(psb_spk_), intent(inout) :: c(:) + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + end subroutine s_base_mask_a + end interface + ! !> Function base_mask_v !! \memberof psb_s_base_vect_type @@ -2583,22 +1629,15 @@ contains !! \param t logical resulting from an and operation on all the tests !! \param info return code ! - subroutine s_base_mask_v(c,x,m,t,info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: c - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: m - integer(psb_ipk_), intent(out) :: info - logical, intent(out) :: t - - info = 0 - if (x%is_dev()) call x%sync() - if (c%is_dev()) call c%sync() - - call m%mask(x%v,c%v,t,info) - end subroutine s_base_mask_v - + interface + module subroutine s_base_mask_v(c,x,m,t,info) + class(psb_s_base_vect_type), intent(inout) :: c + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + end subroutine s_base_mask_v + end interface ! !> Function _base_addconst_a2 @@ -2609,28 +1648,15 @@ contains !! \param b The added term !! \param info return code ! - subroutine s_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() -#if defined(PSB_OPENMP) - n = size(x) - !$omp parallel do private(i) - do i = 1, n - z%v(i) = x(i) + b - end do -#else - z%v = x + b -#endif - info = 0 - - end subroutine s_base_addconst_a2 + interface + module subroutine s_base_addconst_a2(x,b,z,info) + real(psb_spk_), intent(in) :: b + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_addconst_a2 + end interface + ! !> Function _base_addconst_v2 !! \memberof psb_s_base_vect_type @@ -2640,24 +1666,53 @@ contains !! \param b The added term !! \param info return code ! - subroutine s_base_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: b - class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%addconst(x%v,b,info) - end subroutine s_base_addconst_v2 + interface + module subroutine s_base_addconst_v2(x,b,z,info) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: b + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_addconst_v2 + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + real(psb_spk_) :: x(:) + type(psb_s_base_vect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_s_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const + end module psb_s_base_vect_mod module psb_s_base_multivect_mod - use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_s_base_vect_mod @@ -2672,8 +1727,6 @@ module psb_s_base_multivect_mod !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private - public :: psb_s_base_multivect, psb_s_base_multivect_type type psb_s_base_multivect_type !> Values. @@ -2819,43 +1872,13 @@ module psb_s_base_multivect_mod generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_s_base_multivect_type + public :: psb_s_base_multivect, psb_s_base_multivect_type + interface psb_s_base_multivect module procedure constructor, size_const end interface psb_s_base_multivect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - real(psb_spk_) :: x(:,:) - type(psb_s_base_multivect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),& - & size(x,dim=2,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_s_base_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(m,n,info) - - end function size_const + private ! ! Build from a sample @@ -2866,21 +1889,14 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine s_base_mlv_bld_x(x,this) - use psb_realloc_mod - real(psb_spk_), intent(in) :: this(:,:) - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - - call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') - return - end if - x%v(:,:) = this(:,:) - - end subroutine s_base_mlv_bld_x - + interface + module subroutine s_base_mlv_bld_x(x,this) + real(psb_spk_), intent(in) :: this(:,:) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + end subroutine s_base_mlv_bld_x + end interface + ! ! Create with size, but no initialization ! @@ -2890,18 +1906,15 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_mlv_bld_n(x,m,n,scratch) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: m,n - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch=scratch) - - end subroutine s_base_mlv_bld_n - + interface + module subroutine s_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + end subroutine s_base_mlv_bld_n + end interface + !> Function base_mlv_all: !! \memberof psb_s_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -2909,21 +1922,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine s_base_mlv_all(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_s_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(m,n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine s_base_mlv_all + interface + module subroutine s_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_all + end interface !> Function base_mlv_mold: !! \memberof psb_s_base_multivect_type @@ -2931,34 +1936,20 @@ contains !! \param y returned variable !! \param info return code !! - subroutine s_base_mlv_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - class(psb_s_base_multivect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_s_base_multivect_type :: y, stat=info) + interface + module subroutine s_base_mlv_mold(x, y, info) + class(psb_s_base_multivect_type), intent(in) :: x + class(psb_s_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_mold + end interface - end subroutine s_base_mlv_mold - - subroutine s_base_mlv_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) then - call x%sync() - x%v(:,:) = szero - call x%set_host() - call x%set_upd() - end if - - end subroutine s_base_mlv_reinit + interface + module subroutine s_base_mlv_reinit(x, info) + class(psb_s_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -2987,129 +1978,15 @@ contains !! \param info return code !! ! - subroutine s_base_mlv_ins(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr - integer(psb_ipk_), intent(in) :: irl(:) - real(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - nc = size(x%v,2) - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_realloc(isz,nc,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k,:) = val(i,:) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_mlv_vect_ins') - return - end if - - end subroutine s_base_mlv_ins + interface + module subroutine s_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_ins + end interface ! !> Function base_mlv_zero @@ -3117,16 +1994,11 @@ contains !! \brief Zero out contents !! ! - subroutine s_base_mlv_zero(x) - use psi_serial_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) x%v=szero - call x%set_host() - - end subroutine s_base_mlv_zero - + interface + module subroutine s_base_mlv_zero(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_zero + end interface ! ! Assembly. @@ -3141,81 +2013,15 @@ contains !! \param info return code !! ! - - subroutine s_base_mlv_asb(m,n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - real(psb_spk_), allocatable :: vv(:,:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(m,n,vv,info) - vv(:,:) = szero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i),:) = x%v(i,:) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (any(vv(x%iv(i),:).ne.szero)) then - info = psb_err_duplicate_coo - call psb_errpush(info,'mvect-asb') - return - else - vv(x%iv(i),:) = x%v(i,:) - end if - end do - case default - write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: @@ -3225,118 +2031,106 @@ contains !! \param info return code !! ! - subroutine s_base_mlv_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - - end subroutine s_base_mlv_free - - function s_base_mlv_get_ncfs(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function s_base_mlv_get_ncfs - - function s_base_mlv_get_dupl(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function s_base_mlv_get_dupl - - function s_base_mlv_get_state(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function s_base_mlv_get_state - - function s_base_mlv_is_null(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function s_base_mlv_is_null - - function s_base_mlv_is_bld(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function s_base_mlv_is_bld - - function s_base_mlv_is_upd(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function s_base_mlv_is_upd - - function s_base_mlv_is_asb(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function s_base_mlv_is_asb - - subroutine s_base_mlv_set_ncfs(n,x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine s_base_mlv_set_ncfs - - subroutine s_base_mlv_set_dupl(n,x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine s_base_mlv_set_dupl - - subroutine s_base_mlv_set_state(n,x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine s_base_mlv_set_state - - subroutine s_base_mlv_set_null(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine s_base_mlv_set_null - - subroutine s_base_mlv_set_bld(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine s_base_mlv_set_bld - - subroutine s_base_mlv_set_upd(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine s_base_mlv_set_upd - - subroutine s_base_mlv_set_asb(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine s_base_mlv_set_asb - + interface + module subroutine s_base_mlv_free(x, info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_free + end interface + + interface + module function s_base_mlv_get_ncfs(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_mlv_get_ncfs + end interface + + interface + module function s_base_mlv_get_dupl(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_mlv_get_dupl + end interface + + interface + module function s_base_mlv_get_state(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_mlv_get_state + end interface + + interface + module function s_base_mlv_is_null(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + end function s_base_mlv_is_null + end interface + + interface + module function s_base_mlv_is_bld(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + end function s_base_mlv_is_bld + end interface + + interface + module function s_base_mlv_is_upd(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + end function s_base_mlv_is_upd + end interface + + interface + module function s_base_mlv_is_asb(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + end function s_base_mlv_is_asb + end interface + + interface + module subroutine s_base_mlv_set_ncfs(n,x) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine s_base_mlv_set_ncfs + end interface + + interface + module subroutine s_base_mlv_set_dupl(n,x) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine s_base_mlv_set_dupl + end interface + + interface + module subroutine s_base_mlv_set_state(n,x) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine s_base_mlv_set_state + end interface + + interface + module subroutine s_base_mlv_set_null(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_null + end interface + + interface + module subroutine s_base_mlv_set_bld(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_bld + end interface + + interface + module subroutine s_base_mlv_set_upd(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_upd + end interface + + interface + module subroutine s_base_mlv_set_asb(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -3348,11 +2142,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine s_base_mlv_sync(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - end subroutine s_base_mlv_sync + interface + module subroutine s_base_mlv_sync(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_sync + end interface ! !> Function base_mlv_set_host: @@ -3360,11 +2154,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine s_base_mlv_set_host(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - end subroutine s_base_mlv_set_host + interface + module subroutine s_base_mlv_set_host(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_host + end interface ! !> Function base_mlv_set_dev: @@ -3372,11 +2166,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine s_base_mlv_set_dev(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - end subroutine s_base_mlv_set_dev + interface + module subroutine s_base_mlv_set_dev(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_dev + end interface ! !> Function base_mlv_set_sync: @@ -3384,11 +2178,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine s_base_mlv_set_sync(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - end subroutine s_base_mlv_set_sync + interface + module subroutine s_base_mlv_set_sync(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3396,13 +2190,12 @@ contains !! \brief Is vector on external device . !! ! - function s_base_mlv_is_dev(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - logical :: res - - res = .false. - end function s_base_mlv_is_dev + interface + module function s_base_mlv_is_dev(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + end function s_base_mlv_is_dev + end interface ! !> Function base_mlv_is_host @@ -3410,13 +2203,12 @@ contains !! \brief Is vector on standard memory . !! ! - function s_base_mlv_is_host(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function s_base_mlv_is_host + interface + module function s_base_mlv_is_host(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + end function s_base_mlv_is_host + end interface ! !> Function base_mlv_is_sync @@ -3424,35 +2216,25 @@ contains !! \brief Is vector on sync . !! ! - function s_base_mlv_is_sync(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function s_base_mlv_is_sync + interface + module function s_base_mlv_is_sync(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + end function s_base_mlv_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine s_base_mlv_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - class(psb_s_base_multivect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine s_base_mlv_cpy - + interface + module subroutine s_base_mlv_cpy(x, y) + class(psb_s_base_multivect_type), intent(in) :: x + class(psb_s_base_multivect_type), intent(out) :: y + end subroutine s_base_mlv_cpy + end interface - ! ! Size info. ! ! @@ -3461,25 +2243,19 @@ contains !! \brief Number of entries !! ! - function s_base_mlv_get_nrows(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function s_base_mlv_get_nrows + interface + module function s_base_mlv_get_nrows(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_mlv_get_nrows + end interface - function s_base_mlv_get_ncols(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,2) - - end function s_base_mlv_get_ncols + interface + module function s_base_mlv_get_ncols(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function s_base_mlv_get_ncols + end interface ! !> Function base_mlv_get_sizeof @@ -3487,15 +2263,12 @@ contains !! \brief Size in bytesa !! ! - function s_base_mlv_sizeof(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() * x%get_ncols() - - end function s_base_mlv_sizeof + interface + module function s_base_mlv_sizeof(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function s_base_mlv_sizeof + end interface ! !> Function base_mlv_get_fmt @@ -3503,12 +2276,11 @@ contains !! \brief Format !! ! - function s_base_mlv_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function s_base_mlv_get_fmt - + interface + module function s_base_mlv_get_fmt() result(res) + character(len=5) :: res + end function s_base_mlv_get_fmt + end interface ! ! @@ -3518,22 +2290,12 @@ contains !! \brief Extract a copy of the contents !! ! - function s_base_mlv_get_vect(x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - real(psb_spk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info,m,n - m = x%get_nrows() - n = x%get_ncols() - if (.not.allocated(x%v)) return - call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') - return - end if - res(1:m,1:n) = x%v(1:m,1:n) - end function s_base_mlv_get_vect + interface + module function s_base_mlv_get_vect(x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:,:) + end function s_base_mlv_get_vect + end interface ! ! Reset all values @@ -3544,39 +2306,25 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine s_base_mlv_set_scal(x,val) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val - - integer(psb_ipk_) :: info - x%v = val - - end subroutine s_base_mlv_set_scal - + interface + module subroutine s_base_mlv_set_scal(x,val) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + end subroutine s_base_mlv_set_scal + end interface + ! !> Function base_mlv_set_vect !! \memberof psb_s_base_multivect_type !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine s_base_mlv_set_vect(x,val) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_) :: nr, nc - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - nr = min(size(x%v,1),size(val,1)) - nc = min(size(x%v,2),size(val,2)) - - x%v(1:nr,1:nc) = val(1:nr,1:nc) - else - x%v = val - end if - - end subroutine s_base_mlv_set_vect + interface + module subroutine s_base_mlv_set_vect(x,val) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:,:) + end subroutine s_base_mlv_set_vect + end interface ! ! Dot products @@ -3588,36 +2336,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_mlv_vect) to be multiplied by !! - function s_base_mlv_dot_v(n,x,y) result(res) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - real(psb_spk_), external :: sdot - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - res = szero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_s_base_mlv_vect (or its class does not care). - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_s_base_multivect_type) - if (y%is_dev()) call y%sync() - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = sdot(n,x%v(:,j),1,y%v(:,j),1) - end do - class default - res = y%dot(n,x%v) - end select - - end function s_base_mlv_dot_v + interface + module function s_base_mlv_dot_v(n,x,y) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function s_base_mlv_dot_v + end interface ! ! Base workhorse is good old BLAS1 @@ -3629,23 +2354,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function s_base_mlv_dot_a(n,x,y) result(res) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - real(psb_spk_), intent(in) :: y(:,:) - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - real(psb_spk_), external :: sdot - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = sdot(n,x%v(:,j),1,y(:,j),1) - end do - - end function s_base_mlv_dot_a + interface + module function s_base_mlv_dot_a(n,x,y) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function s_base_mlv_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3661,30 +2377,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine s_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_s_base_multivect_type), intent(inout) :: x - class(psb_s_base_multivect_type), intent(inout) :: y - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - - if (present(n)) then - nc = n - else - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - end if - select type(xx => x) - type is (psb_s_base_multivect_type) - call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default - call y%axpby(m,alpha,x%v,beta,info,n=n) - end select - - end subroutine s_base_mlv_axpby_v + interface + module subroutine s_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine s_base_mlv_axpby_v + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3699,26 +2401,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine s_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - real(psb_spk_), intent(in) :: x(:,:) - class(psb_s_base_multivect_type), intent(inout) :: y - real(psb_spk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - if (present(n)) then - nc = n - else - nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) - end if - - call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - - end subroutine s_base_mlv_axpby_a - + interface + module subroutine s_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:,:) + class(psb_s_base_multivect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine s_base_mlv_axpby_a + end interface ! ! Multiple variants of two operations: @@ -3735,31 +2427,21 @@ contains !! \param x The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine s_base_mlv_mlt_mv(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - class(psb_s_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine s_base_mlv_mlt_mv + interface + module subroutine s_base_mlv_mlt_mv(x, y, info) + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_mlt_mv + end interface - subroutine s_base_mlv_mlt_mv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine s_base_mlv_mlt_mv_v + interface + module subroutine s_base_mlv_mlt_mv_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_mlt_mv_v + end interface ! !> Function base_mlv_mlt_ar1 @@ -3768,22 +2450,14 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine s_base_mlv_mlt_ar1(x, y, info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: x(:) - class(psb_s_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n - y%v(i,:) = y%v(i,:)*x(i) - end do - - end subroutine s_base_mlv_mlt_ar1 - + interface + module subroutine s_base_mlv_mlt_ar1(x, y, info) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_mlt_ar1 + end interface + ! !> Function base_mlv_mlt_ar2 !! \memberof psb_s_base_multivect_type @@ -3791,21 +2465,13 @@ contains !! \param x(:,:) The array to be multiplied by !! \param info return code !! - subroutine s_base_mlv_mlt_ar2(x, y, info) - use psi_serial_mod - implicit none - real(psb_spk_), intent(in) :: x(:,:) - class(psb_s_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr,nc - - info = 0 - nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) - nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) - y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - - end subroutine s_base_mlv_mlt_ar2 - + interface + module subroutine s_base_mlv_mlt_ar2(x, y, info) + real(psb_spk_), intent(in) :: x(:,:) + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_mlt_ar2 + end interface ! !> Function base_mlv_mlt_a_2 @@ -3818,54 +2484,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine s_base_mlv_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_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr, nc - - info = 0 - nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == szero) then - if (beta == sone) then - return - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - end if - else - if (alpha == sone) then - if (beta == szero) then - z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == sone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else if (alpha == -sone) then - if (beta == szero) then - z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == sone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else - if (beta == szero) then - z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == sone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - end if - end if - end if - end subroutine s_base_mlv_mlt_a_2 - + interface + module subroutine s_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_mlt_a_2 + end interface + ! !> Function base_mlv_mlt_v_2 !! \memberof psb_s_base_multivect_type @@ -3877,41 +2505,18 @@ contains !! \param y The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine s_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - real(psb_spk_), intent(in) :: alpha,beta - class(psb_s_base_multivect_type), intent(inout) :: x - class(psb_s_base_multivect_type), intent(inout) :: y - class(psb_s_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - if (z%is_dev()) call z%sync() - if (.not.psb_s_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=(x%v) - if (conjgy_) y%v=(y%v) - end if - end subroutine s_base_mlv_mlt_v_2 + interface + module subroutine s_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_spk_), intent(in) :: alpha,beta + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_s_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine s_base_mlv_mlt_v_2 + end interface !!$ !!$ subroutine s_base_mlv_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_base_multivect_type), intent(inout) :: y @@ -3926,8 +2531,6 @@ contains !!$ end subroutine s_base_mlv_mlt_av !!$ !!$ subroutine s_base_mlv_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_base_multivect_type), intent(inout) :: x @@ -3950,17 +2553,13 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine s_base_mlv_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - real(psb_spk_), intent (in) :: alpha - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) x%v = alpha*x%v - - end subroutine s_base_mlv_scal - + interface + module subroutine s_base_mlv_scal(alpha, x) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent (in) :: alpha + end subroutine s_base_mlv_scal + end interface + ! ! Norms 1, 2 and infinity ! @@ -3968,64 +2567,40 @@ contains !! \memberof psb_s_base_multivect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function s_base_mlv_nrm2(n,x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - real(psb_spk_), external :: snrm2 - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = snrm2(n,x%v(:,j),1) - end do - - end function s_base_mlv_nrm2 + interface + module function s_base_mlv_nrm2(n,x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function s_base_mlv_nrm2 + end interface ! !> Function base_mlv_amax !! \memberof psb_s_base_multivect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function s_base_mlv_amax(n,x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = maxval(abs(x%v(1:n,j))) - end do - - end function s_base_mlv_amax - + interface + module function s_base_mlv_amax(n,x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function s_base_mlv_amax + end interface + ! !> Function base_mlv_asum !! \memberof psb_s_base_multivect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function s_base_mlv_asum(n,x) result(res) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_spk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = sum(abs(x%v(1:n,j))) - end do - - end function s_base_mlv_asum + interface + module function s_base_mlv_asum(n,x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + end function s_base_mlv_asum + end interface + ! ! Overwrite with absolute value ! @@ -4034,96 +2609,63 @@ contains !! \memberof psb_s_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine s_base_mlv_absval1(x) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v = abs(x%v) - call x%set_host() - end if - - end subroutine s_base_mlv_absval1 - - subroutine s_base_mlv_absval2(x,y) - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - class(psb_s_base_multivect_type), intent(inout) :: y - integer(psb_ipk_) :: info - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) then - call y%axpby(min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) - call y%absval() - end if - - end subroutine s_base_mlv_absval2 - - - function s_base_mlv_use_buffer() result(res) - implicit none - logical :: res - - res = .true. - end function s_base_mlv_use_buffer - - subroutine s_base_mlv_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: nc - nc = x%get_ncols() - call psb_realloc(n*nc,x%combuf,info) - end subroutine s_base_mlv_new_buffer - - subroutine s_base_mlv_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine s_base_mlv_new_comid - - - subroutine s_base_mlv_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine s_base_mlv_maybe_free_buffer - - subroutine s_base_mlv_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine s_base_mlv_free_buffer - - subroutine s_base_mlv_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine s_base_mlv_free_comid + interface + module subroutine s_base_mlv_absval1(x) + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_absval1 + end interface + + interface + module subroutine s_base_mlv_absval2(x,y) + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + end subroutine s_base_mlv_absval2 + end interface + + + interface + module function s_base_mlv_use_buffer() result(res) + logical :: res + end function s_base_mlv_use_buffer + end interface + + interface + module subroutine s_base_mlv_new_buffer(n,x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_new_buffer + end interface + + interface + module subroutine s_base_mlv_new_comid(n,x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_new_comid + end interface + + interface + module subroutine s_base_mlv_maybe_free_buffer(x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_maybe_free_buffer + end interface + + interface + module subroutine s_base_mlv_free_buffer(x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_free_buffer + end interface + interface + module subroutine s_base_mlv_free_comid(x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_mlv_free_comid + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -4137,23 +2679,14 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine s_base_mlv_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: alpha, beta, y(:) - class(psb_s_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - call psi_gth(n,nc,idx,alpha,x%v,beta,y) - - end subroutine s_base_mlv_gthab + interface + module subroutine s_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_base_multivect_type) :: x + end subroutine s_base_mlv_gthab + end interface ! ! shortcut alpha=1 beta=0 ! @@ -4163,19 +2696,15 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine s_base_mlv_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real(psb_spk_) :: y(:) - class(psb_s_base_multivect_type) :: x - - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine s_base_mlv_gthzv_x + interface + module subroutine s_base_mlv_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_base_multivect_type) :: x + end subroutine s_base_mlv_gthzv_x + end interface ! ! shortcut alpha=1 beta=0 @@ -4186,24 +2715,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine s_base_mlv_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: y(:) - class(psb_s_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine s_base_mlv_gthzv + interface + module subroutine s_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_base_multivect_type) :: x + end subroutine s_base_mlv_gthzv + end interface ! ! shortcut alpha=1 beta=0 ! @@ -4213,48 +2732,27 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine s_base_mlv_gthzm(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: y(:,:) - class(psb_s_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine s_base_mlv_gthzm + interface + module subroutine s_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:,:) + class(psb_s_base_multivect_type) :: x + end subroutine s_base_mlv_gthzm + end interface ! ! New comm internals impl. ! - subroutine s_base_mlv_gthzbuf(i,ixb,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, ixb - class(psb_i_base_vect_type) :: idx - class(psb_s_base_multivect_type) :: x - integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - nc = x%get_ncols() - call x%gth(n,idx%v(i:),x%combuf(ixb:)) - - end subroutine s_base_mlv_gthzbuf - + interface + module subroutine s_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_s_base_multivect_type) :: x + end subroutine s_base_mlv_gthzbuf + end interface + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -4268,72 +2766,43 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine s_base_mlv_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: beta, x(:) - class(psb_s_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = psb_size(y%v,2_psb_ipk_) - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine s_base_mlv_sctb - - subroutine s_base_mlv_sctbr2(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - real(psb_spk_) :: beta, x(:,:) - class(psb_s_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = y%get_ncols() - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine s_base_mlv_sctbr2 - - subroutine s_base_mlv_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - real( psb_spk_) :: beta, x(:) - class(psb_s_base_multivect_type) :: y - - call y%sct(n,idx%v(i:),x,beta) - - end subroutine s_base_mlv_sctb_x - - subroutine s_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, iyb - class(psb_i_base_vect_type) :: idx - real(psb_spk_) :: beta - class(psb_s_base_multivect_type) :: y - integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - nc = y%get_ncols() - call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) - call y%set_host() - - end subroutine s_base_mlv_sctb_buf + interface + module subroutine s_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_base_multivect_type) :: y + end subroutine s_base_mlv_sctb + end interface + + interface + module subroutine s_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:,:) + class(psb_s_base_multivect_type) :: y + end subroutine s_base_mlv_sctbr2 + end interface + + interface + module subroutine s_base_mlv_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_base_multivect_type) :: y + end subroutine s_base_mlv_sctb_x + end interface + + interface + module subroutine s_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta + class(psb_s_base_multivect_type) :: y + end subroutine s_base_mlv_sctb_buf + end interface ! !> Function base_device_wait: @@ -4341,9 +2810,43 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine s_base_mlv_device_wait() - implicit none + interface + module subroutine s_base_mlv_device_wait() + end subroutine s_base_mlv_device_wait + end interface + +contains + + ! + ! Constructors. + ! - end subroutine s_base_mlv_device_wait + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + real(psb_spk_) :: x(:,:) + type(psb_s_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_s_base_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(m,n,info) + + end function size_const end module psb_s_base_multivect_mod diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index c85ea3b63..a06ae7988 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -168,7 +168,10 @@ module psb_s_vect_mod end type psb_s_vect_type - public :: psb_s_vect + public :: psb_s_vect, psb_s_vect_type,& + & psb_s_set_vect_default, psb_s_get_vect_default, & + & psb_s_clear_vect_default, psb_s_base_vect_type + private :: constructor, size_const interface psb_s_vect module procedure constructor, size_const @@ -195,180 +198,758 @@ module psb_s_vect_mod class(psb_s_base_vect_type), allocatable, target,& & save, private :: psb_s_base_vect_default - interface psb_set_vect_default - module procedure psb_s_set_vect_default - end interface psb_set_vect_default - interface psb_get_vect_default - module procedure psb_s_get_vect_default - end interface psb_get_vect_default + interface + module function s_vect_get_dupl(x) result(res) + 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 + 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 + 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 @@ -379,7 +960,6 @@ contains 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 @@ -388,7 +968,6 @@ contains 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) @@ -397,7 +976,6 @@ contains 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 @@ -408,150 +986,6 @@ contains 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,980 +1007,6 @@ 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 y%v%div(x%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 y%v%div(x%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(sone) - 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 @@ -1556,7 +1016,6 @@ module psb_s_multivect_mod use psb_const_mod use psb_i_vect_mod - !private type psb_s_multivect_type @@ -1619,422 +1078,231 @@ module psb_s_multivect_mod end type psb_s_multivect_type public :: psb_s_multivect, psb_s_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default, & - & psb_s_base_multivect_type + & psb_s_set_multivect_default, psb_s_get_base_multivect_default, & + & psb_s_clear_multivect_default, psb_s_base_multivect_type - private interface psb_s_multivect module procedure constructor, size_const end interface psb_s_multivect + private + 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 - + 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 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 - 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 + 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 + integer(psb_ipk_) :: info + end subroutine s_mvect_cnv + end interface -!!$ function s_mvect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ module function s_mvect_dot_v(n,x,y) result(res) !!$ class(psb_s_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res @@ -2046,7 +1314,6 @@ contains !!$ end function s_mvect_dot_v !!$ !!$ 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 @@ -2058,9 +1325,7 @@ contains !!$ !!$ end function s_mvect_dot_a !!$ -!!$ subroutine s_mvect_axpby_v(m,alpha, x, beta, y, info) -!!$ use psi_serial_mod -!!$ implicit none +!!$ module subroutine s_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: y @@ -2076,8 +1341,6 @@ contains !!$ end subroutine s_mvect_axpby_v !!$ !!$ 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 @@ -2091,8 +1354,6 @@ contains !!$ !!$ !!$ 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 @@ -2105,8 +1366,6 @@ contains !!$ end subroutine s_mvect_mlt_v !!$ !!$ 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 @@ -2121,8 +1380,6 @@ contains !!$ !!$ !!$ 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(:) @@ -2137,8 +1394,6 @@ contains !!$ end subroutine s_mvect_mlt_a_2 !!$ !!$ 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 @@ -2156,8 +1411,6 @@ contains !!$ end subroutine s_mvect_mlt_v_2 !!$ !!$ 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 @@ -2172,8 +1425,6 @@ contains !!$ end subroutine s_mvect_mlt_av !!$ !!$ 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 @@ -2189,8 +1440,6 @@ contains !!$ end subroutine s_mvect_mlt_va !!$ !!$ 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 !!$ @@ -2200,7 +1449,6 @@ contains !!$ !!$ !!$ 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 @@ -2214,7 +1462,6 @@ contains !!$ end function s_mvect_nrm2 !!$ !!$ 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 @@ -2228,7 +1475,6 @@ contains !!$ end function s_mvect_amax !!$ !!$ 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 @@ -2241,4 +1487,65 @@ contains !!$ !!$ end function s_mvect_asum +contains + + subroutine psb_s_set_multivect_default(v) + 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) +!!$ 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) + 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 + + 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 + + + subroutine psb_s_clear_multivect_default() + + if (allocated(psb_s_base_multivect_default)) then + deallocate(psb_s_base_multivect_default) + end if + + end subroutine psb_s_clear_multivect_default + end module psb_s_multivect_mod diff --git a/base/modules/serial/psb_vect_mod.f90 b/base/modules/serial/psb_vect_mod.f90 index d82eeffb5..307f429a6 100644 --- a/base/modules/serial/psb_vect_mod.f90 +++ b/base/modules/serial/psb_vect_mod.f90 @@ -20,20 +20,32 @@ contains ! ! Defaults for vectors ! - type(psb_i_base_vect_type) :: ivetdef type(psb_l_base_vect_type) :: lvetdef type(psb_s_base_vect_type) :: svetdef type(psb_d_base_vect_type) :: dvetdef type(psb_c_base_vect_type) :: cvetdef type(psb_z_base_vect_type) :: zvetdef + type(psb_i_base_multivect_type) :: imvetdef + type(psb_l_base_multivect_type) :: lmvetdef + type(psb_s_base_multivect_type) :: smvetdef + type(psb_d_base_multivect_type) :: dmvetdef + type(psb_c_base_multivect_type) :: cmvetdef + type(psb_z_base_multivect_type) :: zmvetdef + + call psb_i_set_vect_default(ivetdef) + call psb_l_set_vect_default(lvetdef) + call psb_s_set_vect_default(svetdef) + call psb_d_set_vect_default(dvetdef) + call psb_c_set_vect_default(cvetdef) + call psb_z_set_vect_default(zvetdef) - call psb_set_vect_default(ivetdef) - call psb_set_vect_default(lvetdef) - call psb_set_vect_default(svetdef) - call psb_set_vect_default(dvetdef) - call psb_set_vect_default(cvetdef) - call psb_set_vect_default(zvetdef) + call psb_i_set_multivect_default(imvetdef) + call psb_l_set_multivect_default(lmvetdef) + call psb_s_set_multivect_default(smvetdef) + call psb_d_set_multivect_default(dmvetdef) + call psb_c_set_multivect_default(cmvetdef) + call psb_z_set_multivect_default(zmvetdef) end subroutine psb_init_vect_defaults @@ -47,6 +59,13 @@ contains call psb_c_clear_vect_default() call psb_z_clear_vect_default() + call psb_i_clear_multivect_default() + call psb_l_clear_multivect_default() + call psb_s_clear_multivect_default() + call psb_d_clear_multivect_default() + call psb_c_clear_multivect_default() + call psb_z_clear_multivect_default() + end subroutine psb_clear_vect_defaults end module psb_vect_mod diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index 6f7167ee2..928c028c0 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -246,45 +246,12 @@ module psb_z_base_vect_mod end type psb_z_base_vect_type - public :: psb_z_base_vect + public :: psb_z_base_vect, psb_z_base_vect_type private :: constructor, size_const interface psb_z_base_vect module procedure constructor, size_const end interface psb_z_base_vect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - complex(psb_dpk_) :: x(:) - type(psb_z_base_vect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(n) result(this) - integer(psb_ipk_), intent(in) :: n - type(psb_z_base_vect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(n,info) - - end function size_const - ! ! Build from a sample ! @@ -294,36 +261,13 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine z_base_bld_x(x,this,scratch) - use psb_realloc_mod - implicit none - complex(psb_dpk_), intent(in) :: this(:) - class(psb_z_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - integer(psb_ipk_) :: i - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(size(this),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') - return - end if -#if defined (PSB_OPENMP) - !$omp parallel do private(i) - do i = 1, size(this) - x%v(i) = this(i) - end do -#else - x%v(:) = this(:) -#endif - end subroutine z_base_bld_x + interface + module subroutine z_base_bld_x(x,this,scratch) + complex(psb_dpk_), intent(in) :: this(:) + class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine z_base_bld_x + end interface ! ! Create with size, but no initialization @@ -334,50 +278,26 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_bld_mn(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_z_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine z_base_bld_mn - + interface + module subroutine z_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine z_base_bld_mn + end interface + !> Function bld_en: !! \memberof psb_z_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_bld_en(x,n,scratch) - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_z_base_vect_type), intent(inout) :: x - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: info - - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - call psb_realloc(n,x%v,info) - call x%asb(n,info,scratch=scratch_) - - end subroutine z_base_bld_en + interface + module subroutine z_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + end subroutine z_base_bld_en + end interface !> Function base_all: !! \memberof psb_z_base_vect_type @@ -386,21 +306,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine z_base_all(n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: n - class(psb_z_base_vect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine z_base_all + interface + module subroutine z_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_z_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_all + end interface !> Function base_mold: !! \memberof psb_z_base_vect_type @@ -408,42 +320,21 @@ contains !! \param y returned variable !! \param info return code !! - subroutine z_base_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(in) :: x - class(psb_z_base_vect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_z_base_vect_type :: y, stat=info) - - end subroutine z_base_mold - - subroutine z_base_reinit(x, info,clear) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: clear - logical :: clear_ - - info = 0 - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - if (clear_) x%v(:) = zzero - call x%set_host() - call x%set_upd() - end if - - end subroutine z_base_reinit + interface + module subroutine z_base_mold(x, y, info) + class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mold + end interface + + interface + module subroutine z_base_reinit(x, info,clear) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + end subroutine z_base_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -472,152 +363,27 @@ contains !! \param info return code !! ! - subroutine z_base_ins_a(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_ensure_size(isz,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k) = val(i) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i)) = x%v(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine z_base_ins_a - - subroutine z_base_ins_v(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl, maxr - class(psb_i_base_vect_type), intent(inout) :: irl - class(psb_z_base_vect_type), intent(inout) :: val - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: isz - - info = 0 - if (psb_errstatus_fatal()) return - - if (irl%is_dev()) call irl%sync() - if (val%is_dev()) call val%sync() - if (x%is_dev()) call x%sync() - call x%ins(n,irl%v,val%v,dupl,maxr,info) - - if (info /= 0) then - call psb_errpush(info,'base_vect_ins') - return - end if - - end subroutine z_base_ins_v + interface + module subroutine z_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_ins_a + end interface + + + interface + module subroutine z_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_z_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_ins_v + end interface + ! @@ -626,18 +392,12 @@ contains !! \brief Zero out contents !! ! - subroutine z_base_zero(x) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x + interface + module subroutine z_base_zero(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_zero + end interface - if (allocated(x%v)) then - !$omp workshare - x%v(:)=zzero - !$omp end workshare - end if - call x%set_host() - end subroutine z_base_zero ! @@ -654,74 +414,15 @@ contains !! ! - subroutine z_base_asb_m(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_mpk_), intent(in) :: n - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - complex(psb_dpk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(n,vv,info) - vv(:) = zzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (vv(x%iv(i)).ne. zzero) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine z_base_asb_m + interface + module subroutine z_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine z_base_asb_m + end interface + ! ! Assembly. @@ -737,74 +438,15 @@ contains !! ! - subroutine z_base_asb_e(n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_epk_), intent(in) :: n - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - complex(psb_dpk_), allocatable :: vv(:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') - if (x%is_bld()) then - call psb_realloc(n,vv,info) - vv(:) = zzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) - end do - case(psb_dupl_ovwrt_) - do i=1,x%get_ncfs() - vv(x%iv(i)) = x%v(i) - end do - case(psb_dupl_err_) - do i=1,x%get_ncfs() - if (vv(x%iv(i)).ne. zzero) then - call psb_errpush(psb_err_duplicate_coo,'vect_asb') - return - else - vv(x%iv(i)) = x%v(i) - end if - end do - case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - else - info = psb_err_invalid_vect_state_ - call psb_errpush(info,'vect_asb') - end if - else - if (x%get_nrows() < n) & - & call psb_realloc(n,x%v,info) - if (info /= 0) & - & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if - call x%set_host() - call x%set_asb() - call x%sync() - end subroutine z_base_asb_e + interface + module subroutine z_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine z_base_asb_e + end interface + ! !> Function base_free: @@ -814,22 +456,13 @@ contains !! \param info return code !! ! - subroutine z_base_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine z_base_free(x, info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_free + end interface - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - call x%set_null() - end subroutine z_base_free ! !> Function base_free_buffer: @@ -839,15 +472,13 @@ contains !! \param info return code !! ! - subroutine z_base_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine z_base_free_buffer(x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_free_buffer + end interface - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine z_base_free_buffer ! !> Function base_maybe_free_buffer: @@ -860,17 +491,13 @@ contains !! \param info return code !! ! - subroutine z_base_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) + interface + module subroutine z_base_maybe_free_buffer(x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_maybe_free_buffer + end interface - end subroutine z_base_maybe_free_buffer ! !> Function base_free_comid: @@ -880,113 +507,107 @@ contains !! \param info return code !! ! - subroutine z_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine z_base_free_comid - - function z_base_get_ncfs(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function z_base_get_ncfs - - function z_base_get_dupl(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function z_base_get_dupl - - function z_base_get_state(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function z_base_get_state - - function z_base_is_null(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function z_base_is_null - - function z_base_is_bld(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function z_base_is_bld - - function z_base_is_upd(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function z_base_is_upd - - function z_base_is_asb(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function z_base_is_asb - - subroutine z_base_set_ncfs(n,x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine z_base_set_ncfs - - subroutine z_base_set_dupl(n,x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine z_base_set_dupl - - subroutine z_base_set_state(n,x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine z_base_set_state - - subroutine z_base_set_null(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine z_base_set_null - - subroutine z_base_set_bld(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine z_base_set_bld - - subroutine z_base_set_upd(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine z_base_set_upd - - subroutine z_base_set_asb(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine z_base_set_asb + interface + module subroutine z_base_free_comid(x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_free_comid + end interface + + + interface + module function z_base_get_ncfs(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_get_ncfs + end interface + + interface + module function z_base_get_dupl(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_get_dupl + end interface + + interface + module function z_base_get_state(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_get_state + end interface + + interface + module function z_base_is_null(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + end function z_base_is_null + end interface + + interface + module function z_base_is_bld(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + end function z_base_is_bld + end interface + + interface + module function z_base_is_upd(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + end function z_base_is_upd + end interface + + interface + module function z_base_is_asb(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + end function z_base_is_asb + end interface + + interface + module subroutine z_base_set_ncfs(n,x) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine z_base_set_ncfs + end interface + + interface + module subroutine z_base_set_dupl(n,x) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine z_base_set_dupl + end interface + + interface + module subroutine z_base_set_state(n,x) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine z_base_set_state + end interface + + interface + module subroutine z_base_set_null(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_set_null + end interface + + interface + module subroutine z_base_set_bld(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_set_bld + end interface + + interface + module subroutine z_base_set_upd(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_set_upd + end interface + + interface + module subroutine z_base_set_asb(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -998,11 +619,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine z_base_sync(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - end subroutine z_base_sync + interface + module subroutine z_base_sync(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_sync + end interface ! !> Function base_set_host: @@ -1010,11 +631,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine z_base_set_host(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - end subroutine z_base_set_host + interface + module subroutine z_base_set_host(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_set_host + end interface ! !> Function base_set_dev: @@ -1022,11 +643,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine z_base_set_dev(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - end subroutine z_base_set_dev + interface + module subroutine z_base_set_dev(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_set_dev + end interface ! !> Function base_set_sync: @@ -1034,11 +655,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine z_base_set_sync(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - end subroutine z_base_set_sync + interface + module subroutine z_base_set_sync(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_set_sync + end interface ! !> Function base_is_dev: @@ -1046,13 +667,12 @@ contains !! \brief Is vector on external device . !! ! - function z_base_is_dev(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - logical :: res - - res = .false. - end function z_base_is_dev + interface + module function z_base_is_dev(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + end function z_base_is_dev + end interface ! !> Function base_is_host @@ -1060,13 +680,12 @@ contains !! \brief Is vector on standard memory . !! ! - function z_base_is_host(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function z_base_is_host + interface + module function z_base_is_host(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + end function z_base_is_host + end interface ! !> Function base_is_sync @@ -1074,32 +693,24 @@ contains !! \brief Is vector on sync . !! ! - function z_base_is_sync(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - logical :: res - - res = .true. - end function z_base_is_sync + interface + module function z_base_is_sync(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + end function z_base_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine z_base_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(in) :: x - class(psb_z_base_vect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine z_base_cpy + interface + module subroutine z_base_cpy(x, y) + class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(out) :: y + end subroutine z_base_cpy + end interface ! ! Size info. @@ -1110,15 +721,12 @@ contains !! \brief Number of entries !! ! - function z_base_get_nrows(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v) - - end function z_base_get_nrows + interface + module function z_base_get_nrows(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_get_nrows + end interface ! !> Function base_get_sizeof @@ -1126,15 +734,12 @@ contains !! \brief Size in bytes !! ! - function z_base_sizeof(x) result(res) - implicit none - class(psb_z_base_vect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() - - end function z_base_sizeof + interface + module function z_base_sizeof(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + end function z_base_sizeof + end interface ! !> Function base_get_fmt @@ -1142,12 +747,11 @@ contains !! \brief Format !! ! - function z_base_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function z_base_get_fmt - + interface + module function z_base_get_fmt() result(res) + character(len=5) :: res + end function z_base_get_fmt + end interface ! ! @@ -1157,34 +761,14 @@ contains !! \brief Extract a copy of the contents !! ! - function z_base_get_vect(x,n) result(res) - class(psb_z_base_vect_type), intent(inout) :: x - complex(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional :: n - ! Local variables - integer(psb_ipk_) :: isz, i - - if (.not.allocated(x%v)) return - if (.not.x%is_host()) call x%sync() - isz = x%get_nrows() - if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') - return - end if - if (.false.) then - res(1:isz) = x%v(1:isz) - else - !$omp parallel do private(i) - do i=1, isz - res(i) = x%v(i) - end do - end if - - end function z_base_get_vect - + interface + module function z_base_get_vect(x,n) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_), optional :: n + end function z_base_get_vect + end interface + ! ! Reset all values ! @@ -1194,32 +778,13 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine z_base_set_scal(x,val,first,last) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i - - first_=1 - last_=size(x%v) - if (present(first)) first_ = max(1,first) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val - end do -#else - x%v(first_:last_) = val -#endif - call x%set_host() - - end subroutine z_base_set_scal - + interface + module subroutine z_base_set_scal(x,val,first,last) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + end subroutine z_base_set_scal + end interface ! !> Function base_set_vect @@ -1227,45 +792,20 @@ contains !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine z_base_set_vect(x,val,first,last) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), optional :: first, last - - integer(psb_ipk_) :: first_, last_, i, info - - if (.not.allocated(x%v)) then - call psb_realloc(size(val),x%v,info) - end if - - first_ = 1 - if (present(first)) first_ = max(1,first) - last_ = min(psb_size(x%v),first_+size(val)-1) - if (present(last)) last_ = min(last,last_) - - if (x%is_dev()) call x%sync() - -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i = first_, last_ - x%v(i) = val(i-first_+1) - end do -#else - x%v(first_:last_) = val(1:last_-first_+1) -#endif - call x%set_host() - - end subroutine z_base_set_vect - - subroutine z_base_check_addr(x) - class(psb_z_base_vect_type), intent(inout) :: x - - write(0,*) 'Check addr: base version, do nothing' - - end subroutine z_base_check_addr - - + interface + module subroutine z_base_set_vect(x,val,first,last) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + end subroutine z_base_set_vect + end interface + + interface + module subroutine z_base_check_addr(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_check_addr + end interface + ! ! Get entry. ! @@ -1275,33 +815,22 @@ contains !! \brief Get one entry from the vector !! ! - function z_base_get_entry(x, index) result(res) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_dpk_) :: res - - res = zzero - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - res = x%v(index) - end if - - end function z_base_get_entry - - subroutine z_base_set_entry(x, index, val) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_dpk_) :: val - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v(index) =val - call x%set_host() - end if - end subroutine z_base_set_entry - + interface + module function z_base_get_entry(x, index) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: res + end function z_base_get_entry + end interface + + interface + module subroutine z_base_set_entry(x, index, val) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + end subroutine z_base_set_entry + end interface + ! ! Overwrite with absolute value ! @@ -1310,40 +839,19 @@ contains !! \memberof psb_z_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine z_base_absval1(x) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - - integer(psb_ipk_) :: i - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1, size(x%v) - x%v(i) = abs(x%v(i)) - end do -#else - x%v = abs(x%v) -#endif - call x%set_host() - end if - - end subroutine z_base_absval1 - - subroutine z_base_absval2(x,y) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_) :: info - if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then - call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) - call y%absval() - end if - - end subroutine z_base_absval2 - + interface + module subroutine z_base_absval1(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_absval1 + end interface + + interface + module subroutine z_base_absval2(x,y) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + end subroutine z_base_absval2 + end interface + ! ! Dot products ! @@ -1354,29 +862,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_vect) to be multiplied by !! - function z_base_dot_v(n,x,y) result(res) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - complex(psb_dpk_) :: res - complex(psb_dpk_), external :: zdotc - - res = zzero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_z_base_vect. - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_z_base_vect_type) - res = zdotc(n,x%v,1,y%v,1) - class default - res = y%dot(n,x%v) - end select - - end function z_base_dot_v + interface + module function z_base_dot_v(n,x,y) result(res) + class(psb_z_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + end function + end interface ! ! Base workhorse is good old BLAS1 @@ -1388,17 +880,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function z_base_dot_a(n,x,y) result(res) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(in) :: n - complex(psb_dpk_) :: res - complex(psb_dpk_), external :: zdotc - - res = zdotc(n,y,1,x%v,1) - - end function z_base_dot_a + interface + module function z_base_dot_a(n,x,y) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + end function z_base_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1414,20 +903,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine z_base_axpby_v(m,alpha, x, beta, y, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call y%axpby(m,alpha,x%v,beta,info) - - end subroutine z_base_axpby_v + interface + module subroutine z_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_axpby_v + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1445,21 +929,16 @@ contains !! \param z The class(base_vect) to be returned !! \param info return code !! - subroutine z_base_axpby_v2(m,alpha, x, beta, y, z, info) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - class(psb_z_base_vect_type), intent(inout) :: z - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev()) call x%sync() - - call z%axpby(m,alpha,x%v,beta,y%v,info) - - end subroutine z_base_axpby_v2 + interface + module subroutine z_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_axpby_v2 + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -1474,20 +953,15 @@ contains !! \param beta scalar beta !! \param info return code !! - subroutine z_base_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_base_vect_type), intent(inout) :: y - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (y%is_dev()) call y%sync() - call psb_geaxpby(m,alpha,x,beta,y%v,info) - call y%set_host() - - end subroutine z_base_axpby_a + interface + module subroutine z_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_axpby_a + end interface ! ! AXPBY is invoked via Z, hence the structure below. @@ -1503,21 +977,16 @@ contains !! \param y(:) The array to be added !! \param info return code !! - subroutine z_base_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_base_vect_type), intent(inout) :: z - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - - if (z%is_dev()) call z%sync() - call psb_geaxpby(m,alpha,x,beta,y,z%v,info) - call z%set_host() - - end subroutine z_base_axpby_a2 + interface + module subroutine z_base_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_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_axpby_a2 + end interface ! ! UPD_XYZ is invoked via Z, hence the structure below. @@ -1536,48 +1005,29 @@ contains !! \param z The class(base_vect) to be added !! \param info return code !! - subroutine z_base_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_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - class(psb_z_base_vect_type), intent(inout) :: z - complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(alpha/=zzero)) call x%sync() - if (y%is_dev().and.(beta/=zzero)) call y%sync() - if (z%is_dev().and.(delta/=zzero)) call z%sync() - call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) - call y%set_host() - call z%set_host() - - end subroutine z_base_upd_xyz - - subroutine z_base_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_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - class(psb_z_base_vect_type), intent(inout) :: z - class(psb_z_base_vect_type), intent(inout) :: w - complex(psb_dpk_), intent (in) :: a,b,c,d,e,f - integer(psb_ipk_), intent(out) :: info - - if (x%is_dev().and.(a/=zzero)) call x%sync() - if (y%is_dev().and.(b/=zzero)) call y%sync() - if (z%is_dev().and.(d/=zzero)) call z%sync() - if (w%is_dev().and.(f/=zzero)) call w%sync() - call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) - call y%set_host() - call z%set_host() - call w%set_host() - - end subroutine z_base_xyzw - - + interface + module subroutine z_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_upd_xyz + end interface + + interface + module subroutine z_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + class(psb_z_base_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_base_xyzw + end interface + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -1593,20 +1043,14 @@ contains !! \param x The class(base_vect) to be multiplied by !! \param info return code !! - subroutine z_base_mlt_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine z_base_mlt_v - + interface + module subroutine z_base_mlt_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlt_v + end interface + ! !> Function base_mlt_a !! \memberof psb_z_base_vect_type @@ -1614,25 +1058,13 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine z_base_mlt_a(x, y, info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: x(:) - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)*x(i) - end do - call y%set_host() - - end subroutine z_base_mlt_a - + interface + module subroutine z_base_mlt_a(x, y, info) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlt_a + end interface ! !> Function base_mlt_a_2 @@ -1645,87 +1077,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine z_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(z%v), size(x), size(y)) - if (alpha == zzero) then - if (beta == zone) then - return - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - end do - end if - else - if (alpha == zone) then - if (beta == zzero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = y(i)*x(i) - end do - else if (beta == zone) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) + y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) + y(i)*x(i) - end do - end if - else if (alpha == -zone) then - if (beta == zzero) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = -y(i)*x(i) - end do - else if (beta == zone) then - !$omp parallel do private(i) - do i=1, n - z%v(i) = z%v(i) - y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(beta) - do i=1, n - z%v(i) = beta*z%v(i) - y(i)*x(i) - end do - end if - else - if (beta == zzero) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = alpha*y(i)*x(i) - end do - else if (beta == zone) then - !$omp parallel do private(i) shared(alpha) - do i=1, n - z%v(i) = z%v(i) + alpha*y(i)*x(i) - end do - else - !$omp parallel do private(i) shared(alpha, beta) - do i=1, n - z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) - end do - end if - end if - end if - call z%set_host() - - end subroutine z_base_mlt_a_2 - + interface + module subroutine z_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlt_a_2 + end interface + ! !> Function base_mlt_v_2 !! \memberof psb_z_base_vect_type @@ -1737,68 +1098,37 @@ contains !! \param y The class(base_vect) to be multiplied by !! \param info return code !! - subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - complex(psb_dpk_), intent(in) :: alpha,beta - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (y%is_dev()) call y%sync() - if (x%is_dev()) call x%sync() - if (.not.psb_z_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - end if - end subroutine z_base_mlt_v_2 - - subroutine z_base_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_base_vect_type), intent(inout) :: y - class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call z%mlt(alpha,x,y%v,beta,info) - - end subroutine z_base_mlt_av - - subroutine z_base_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_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call z%mlt(alpha,y,x,beta,info) - - end subroutine z_base_mlt_va + interface + module subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_dpk_), intent(in) :: alpha,beta + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine z_base_mlt_v_2 + end interface + + interface + module subroutine z_base_mlt_av(alpha,x,y,beta,z,info) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlt_av + end interface + + interface + module subroutine z_base_mlt_va(alpha,x,y,beta,z,info) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlt_va + end interface + ! !> Function base_div_v !! \memberof psb_z_base_vect_type @@ -1806,38 +1136,22 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine z_base_div_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - call y%div(x%v,info) - - end subroutine z_base_div_v - - subroutine z_base_div_a(x, y, info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: x(:) - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - n = min(size(y%v), size(x)) - !$omp parallel do private(i) - do i=1, n - y%v(i) = y%v(i)/x(i) - end do - call y%set_host() - - end subroutine z_base_div_a + interface + module subroutine z_base_div_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_div_v + end interface + + interface + module subroutine z_base_div_a(x, y, info) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_div_a + end interface + ! !> Function base_div_v2 !! \memberof psb_z_base_vect_type @@ -1845,21 +1159,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine z_base_div_v2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call z%div(x%v,y%v,info) - call z%set_host() - end subroutine z_base_div_v2 + interface + module subroutine z_base_div_v2(x, y, z, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_div_v2 + end interface + ! !> Function base_div_v_check !! \memberof psb_z_base_vect_type @@ -1867,21 +1175,15 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine z_base_div_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - call x%div(x%v,y%v,info,flag) - - end subroutine z_base_div_v_check + interface + module subroutine z_base_div_v_check(x, y, info, flag) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_base_div_v_check + end interface + ! !> Function base_div_v2_check !! \memberof psb_z_base_vect_type @@ -1889,21 +1191,16 @@ contains !! \param y The array to be divided by !! \param info return code !! - subroutine z_base_div_v2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info,flag) - - end subroutine z_base_div_v2_check + interface + module subroutine z_base_div_v2_check(x, y, z, info, flag) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_base_div_v2_check + end interface + ! !> Function base_div_a2 !! \memberof psb_z_base_vect_type @@ -1911,25 +1208,15 @@ contains !! \param y(:) The array to be divided by !! \param info return code !! - subroutine z_base_div_a2(x, y, z, info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: z - complex(psb_dpk_), intent(in) :: x(:) - complex(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - !$omp parallel do private(i) - do i=1, n - z%v(i) = x(i)/y(i) - end do - - end subroutine z_base_div_a2 + interface + module subroutine z_base_div_a2(x, y, z, info) + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_div_a2 + end interface + ! !> Function base_div_a2_check !! \memberof psb_z_base_vect_type @@ -1938,35 +1225,16 @@ contains !! \param y(:) The array to be dived by !! \param info return code !! - subroutine z_base_div_a2_check(x, y, z, info, flag) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: z - complex(psb_dpk_), intent(in) :: x(:) - complex(psb_dpk_), intent(in) :: y(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call z_base_div_a2(x, y, z, info) - else - info = 0 - if (z%is_dev()) call z%sync() - - n = min(size(y), size(x)) - ! $omp parallel do private(i) - do i=1, n - if (y(i) /= 0) then - z%v(i) = x(i)/y(i) - else - info = 1 - exit - end if - end do - end if - - end subroutine z_base_div_a2_check + interface + module subroutine z_base_div_a2_check(x, y, z, info, flag) + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_base_div_a2_check + end interface + ! !> Function base_inv_v !! \memberof psb_z_base_vect_type @@ -1974,20 +1242,14 @@ contains !! \param x The vector to be inverted !! \param y The vector containing the inverted vector !! \param info return code - subroutine z_base_inv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info) - - - end subroutine z_base_inv_v + interface + module subroutine z_base_inv_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_inv_v + end interface + ! !> Function base_inv_v_check !! \memberof psb_z_base_vect_type @@ -1996,20 +1258,16 @@ contains !! \param y The vector containing the inverted vector !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v - subroutine z_base_inv_v_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - logical, intent(in) :: flag - - info = 0 - if (y%is_dev()) call y%sync() - call y%inv(x%v,info,flag) - - end subroutine z_base_inv_v_check + interface + module subroutine z_base_inv_v_check(x, y, info, flag) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + end subroutine z_base_inv_v_check + end interface + ! !> Function base_inv_a2 !! \memberof psb_z_base_vect_type @@ -2018,24 +1276,14 @@ contains !! \param y The vector containing the inverted vector !! \param info return code ! - subroutine z_base_inv_a2(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: y - complex(psb_dpk_), intent(in) :: x(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - y%v(i) = 1_psb_dpk_/x(i) - end do - - end subroutine z_base_inv_a2 + interface + module subroutine z_base_inv_a2(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_inv_a2 + end interface + ! !> Function base_inv_a2_check !! \memberof psb_z_base_vect_type @@ -2045,35 +1293,14 @@ contains !! \param info return code !! \param flag if true does the check, otherwise call base_inv_v ! - subroutine z_base_inv_a2_check(x, y, info, flag) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: y - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in) :: flag - integer(psb_ipk_) :: i, n - - if (flag .eqv. .false.) then - call z_base_inv_a2(x, y, info) - else - info = 0 - if (y%is_dev()) call y%sync() - - n = size(x) - !$omp parallel do private(i) - do i=1, n - if (x(i) /= 0) then - y%v(i) = 1_psb_dpk_/x(i) - else - info = 1 - y%v(i) = 0_psb_dpk_ - end if - end do - end if - - - end subroutine z_base_inv_a2_check + interface + module subroutine z_base_inv_a2_check(x, y, info, flag) + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine z_base_inv_a2_check + end interface ! !> Function base_inv_a2_check @@ -2084,29 +1311,15 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine z_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() - - n = size(x) - !$omp parallel do private(i) - do i = 1, n, 1 - if ( abs(x(i)).ge.c ) then - z%v(i) = 1_psb_dpk_ - else - z%v(i) = 0_psb_dpk_ - end if - end do - info = 0 - - end subroutine z_base_acmp_a2 + interface + module subroutine z_base_acmp_a2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_acmp_a2 + end interface + ! !> Function base_cmp_v2 !! \memberof psb_z_base_vect_type @@ -2116,18 +1329,14 @@ contains !! \param c The comparison term !! \param info return code ! - subroutine z_base_acmp_v2(x,c,z,info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: c - class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%acmp(x%v,c,info) - end subroutine z_base_acmp_v2 + interface + module subroutine z_base_acmp_v2(x,c,z,info) + class(psb_z_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_acmp_v2 + end interface ! ! Simple scaling @@ -2137,25 +1346,12 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine z_base_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - complex(psb_dpk_), intent (in) :: alpha - integer(psb_ipk_) :: i - - if (allocated(x%v)) then -#if defined(PSB_OPENMP) - !$omp parallel do private(i) - do i=1,size(x%v) - x%v(i) = alpha*x%v(i) - end do -#else - x%v = alpha*x%v -#endif - end if - call x%set_host() - end subroutine z_base_scal + interface + module subroutine z_base_scal(alpha, x) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent (in) :: alpha + end subroutine z_base_scal + end interface ! ! Norms 1, 2 and infinity @@ -2164,67 +1360,39 @@ contains !! \memberof psb_z_base_vect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function z_base_nrm2(n,x) result(res) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - real(psb_dpk_), external :: dznrm2 - - if (x%is_dev()) call x%sync() - res = dznrm2(n,x%v,1) - - end function z_base_nrm2 + interface + module function z_base_nrm2(n,x) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function z_base_nrm2 + end interface ! !> Function base_amax !! \memberof psb_z_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function z_base_amax(n,x) result(res) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res = dzero - !$omp parallel do private(i) reduction(max: res) - do i=1, n - res = max(res,abs(x%v(i))) - end do -#else - res = maxval(abs(x%v(1:n))) -#endif - end function z_base_amax - + interface + module function z_base_amax(n,x) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function z_base_amax + end interface ! !> Function base_asum !! \memberof psb_z_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function z_base_asum(n,x) result(res) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_) :: res - integer(psb_ipk_) :: i - - if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) - res=dzero - !$omp parallel do private(i) reduction(+: res) - do i= 1, size(x%v) - res = res + abs(x%v(i)) - end do -#else - res = sum(abs(x%v(1:n))) -#endif - end function z_base_asum - + interface + module function z_base_asum(n,x) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + end function z_base_asum + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -2238,18 +1406,15 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine z_base_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: alpha, beta, y(:) - class(psb_z_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,alpha,x%v,beta,y) - - end subroutine z_base_gthab + interface + module subroutine z_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_base_vect_type) :: x + end subroutine z_base_gthab + end interface + ! ! shortcut alpha=1 beta=0 ! @@ -2259,77 +1424,60 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine z_base_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - complex(psb_dpk_) :: y(:) - class(psb_z_base_vect_type) :: x - - if (idx%is_dev()) call idx%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine z_base_gthzv_x - + interface + module subroutine z_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: y(:) + class(psb_z_base_vect_type) :: x + end subroutine z_base_gthzv_x + end interface + ! ! New comm internals impl. ! - subroutine z_base_gthzbuf(i,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_ipk_) :: i - integer(psb_mpk_) :: n - class(psb_i_base_vect_type) :: idx - class(psb_z_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),x%combuf(i:)) - - end subroutine z_base_gthzbuf + interface + module subroutine z_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_z_base_vect_type) :: x + end subroutine z_base_gthzbuf + end interface + ! !> Function base_device_wait: !! \memberof psb_z_base_vect_type !! \brief device_wait: base version is a no-op. !! ! - subroutine z_base_device_wait() - implicit none - - end subroutine z_base_device_wait - - function z_base_use_buffer() result(res) - logical :: res - - res = .true. - end function z_base_use_buffer - - subroutine z_base_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,x%combuf,info) - end subroutine z_base_new_buffer - - subroutine z_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine z_base_new_comid + interface + module subroutine z_base_device_wait() + end subroutine z_base_device_wait + end interface + interface + module function z_base_use_buffer() result(res) + logical :: res + end function z_base_use_buffer + end interface + + interface + module subroutine z_base_new_buffer(n,x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_new_buffer + end interface + + interface + module subroutine z_base_new_comid(n,x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_new_comid + end interface ! ! shortcut alpha=1 beta=0 @@ -2340,18 +1488,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine z_base_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: y(:) - class(psb_z_base_vect_type) :: x - - if (x%is_dev()) call x%sync() - call psi_gth(n,idx,x%v,y) - - end subroutine z_base_gthzv + interface + module subroutine z_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_base_vect_type) :: x + end subroutine z_base_gthzv + end interface ! ! Scatter: @@ -2366,57 +1510,35 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine z_base_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: beta, x(:) - class(psb_z_base_vect_type) :: y - - if (y%is_dev()) call y%sync() - call psi_sct(n,idx,x,beta,y%v) - call y%set_host() - - end subroutine z_base_sctb - - subroutine z_base_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_dpk_) :: beta, x(:) - class(psb_z_base_vect_type) :: y - - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),x,beta) - call y%set_host() - - end subroutine z_base_sctb_x - - subroutine z_base_sctb_buf(i,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_dpk_) :: beta - class(psb_z_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - call y%sct(n,idx%v(i:),y%combuf(i:),beta) - call y%set_host() - - end subroutine z_base_sctb_buf - - + interface + module subroutine z_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_base_vect_type) :: y + end subroutine z_base_sctb + end interface + + interface + module subroutine z_base_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_base_vect_type) :: y + end subroutine z_base_sctb_x + end interface + + interface + module subroutine z_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta + class(psb_z_base_vect_type) :: y + end subroutine z_base_sctb_buf + end interface + ! !> Function _base_addconst_a2 !! \memberof psb_z_base_vect_type @@ -2426,28 +1548,15 @@ contains !! \param b The added term !! \param info return code ! - subroutine z_base_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_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - if (z%is_dev()) call z%sync() -#if defined(PSB_OPENMP) - n = size(x) - !$omp parallel do private(i) - do i = 1, n - z%v(i) = x(i) + b - end do -#else - z%v = x + b -#endif - info = 0 - - end subroutine z_base_addconst_a2 + interface + module subroutine z_base_addconst_a2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_addconst_a2 + end interface + ! !> Function _base_addconst_v2 !! \memberof psb_z_base_vect_type @@ -2457,24 +1566,53 @@ contains !! \param b The added term !! \param info return code ! - subroutine z_base_addconst_v2(x,b,z,info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - real(psb_dpk_), intent(in) :: b - class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call z%addconst(x%v,b,info) - end subroutine z_base_addconst_v2 + interface + module subroutine z_base_addconst_v2(x,b,z,info) + class(psb_z_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: b + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_addconst_v2 + end interface + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + complex(psb_dpk_) :: x(:) + type(psb_z_base_vect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_z_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const + end module psb_z_base_vect_mod module psb_z_base_multivect_mod - use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_z_base_vect_mod @@ -2489,8 +1627,6 @@ module psb_z_base_multivect_mod !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private - public :: psb_z_base_multivect, psb_z_base_multivect_type type psb_z_base_multivect_type !> Values. @@ -2636,43 +1772,13 @@ module psb_z_base_multivect_mod generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_z_base_multivect_type + public :: psb_z_base_multivect, psb_z_base_multivect_type + interface psb_z_base_multivect module procedure constructor, size_const end interface psb_z_base_multivect -contains - - ! - ! Constructors. - ! - - !> Function constructor: - !! \brief Constructor from an array - !! \param x(:) input array to be copied - !! - function constructor(x) result(this) - complex(psb_dpk_) :: x(:,:) - type(psb_z_base_multivect_type) :: this - integer(psb_ipk_) :: info - - this%v = x - call this%asb(size(x,dim=1,kind=psb_ipk_),& - & size(x,dim=2,kind=psb_ipk_),info) - end function constructor - - - !> Function constructor: - !! \brief Constructor from size - !! \param n Size of vector to be built. - !! - function size_const(m,n) result(this) - integer(psb_ipk_), intent(in) :: m,n - type(psb_z_base_multivect_type) :: this - integer(psb_ipk_) :: info - - call this%asb(m,n,info) - - end function size_const + private ! ! Build from a sample @@ -2683,21 +1789,14 @@ contains !! \brief Build method from an array !! \param x(:) input array to be copied !! - subroutine z_base_mlv_bld_x(x,this) - use psb_realloc_mod - complex(psb_dpk_), intent(in) :: this(:,:) - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - - call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') - return - end if - x%v(:,:) = this(:,:) - - end subroutine z_base_mlv_bld_x - + interface + module subroutine z_base_mlv_bld_x(x,this) + complex(psb_dpk_), intent(in) :: this(:,:) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + end subroutine z_base_mlv_bld_x + end interface + ! ! Create with size, but no initialization ! @@ -2707,18 +1806,15 @@ contains !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_mlv_bld_n(x,m,n,scratch) - use psb_realloc_mod - integer(psb_ipk_), intent(in) :: m,n - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_) :: info - logical, intent(in), optional :: scratch - - call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch=scratch) - - end subroutine z_base_mlv_bld_n - + interface + module subroutine z_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + end subroutine z_base_mlv_bld_n + end interface + !> Function base_mlv_all: !! \memberof psb_z_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -2726,21 +1822,13 @@ contains !! \param n size to be allocated. !! \param info return code !! - subroutine z_base_mlv_all(m,n, x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_z_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(m,n,x%v,info) - if (try_newins) then - call psb_realloc(n,x%iv,info) - call x%set_ncfs(0) - end if - - end subroutine z_base_mlv_all + interface + module subroutine z_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_all + end interface !> Function base_mlv_mold: !! \memberof psb_z_base_multivect_type @@ -2748,34 +1836,20 @@ contains !! \param y returned variable !! \param info return code !! - subroutine z_base_mlv_mold(x, y, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - class(psb_z_base_multivect_type), intent(out), allocatable :: y - integer(psb_ipk_), intent(out) :: info - - allocate(psb_z_base_multivect_type :: y, stat=info) - - end subroutine z_base_mlv_mold - - subroutine z_base_mlv_reinit(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(out) :: x - integer(psb_ipk_), intent(out) :: info + interface + module subroutine z_base_mlv_mold(x, y, info) + class(psb_z_base_multivect_type), intent(in) :: x + class(psb_z_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_mold + end interface - info = 0 - if (allocated(x%v)) then - call x%sync() - x%v(:,:) = zzero - call x%set_host() - call x%set_upd() - end if - - end subroutine z_base_mlv_reinit + interface + module subroutine z_base_mlv_reinit(x, info) + class(psb_z_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_reinit + end interface ! ! Insert a bunch of values at specified positions. @@ -2804,129 +1878,15 @@ contains !! \param info return code !! ! - subroutine z_base_mlv_ins(n,irl,val,dupl,x,maxr,info) - use psi_serial_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n, dupl,maxr - integer(psb_ipk_), intent(in) :: irl(:) - complex(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k - - info = 0 - if (psb_errstatus_fatal()) return - - if (try_newins) then - if (x%is_bld()) then - nc = size(x%v,2) - ncfs_ = x%get_ncfs() - isz = ncfs_ + n - call psb_realloc(isz,nc,x%v,info) - call psb_ensure_size(isz,x%iv,info) - k = ncfs_ - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - k = k + 1 - ! this row belongs to me - ! copy i-th row of block val in x - x%v(k,:) = val(i,:) - x%iv(k) = irl(i) - end if - enddo - call x%set_ncfs(k) - - else if (x%is_upd()) then - - dupl_ = x%get_dupl() - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= maxr)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - else - info = psb_err_invalid_vect_state_ - end if - else - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then - info = psb_err_invalid_input_ - - else - isz = size(x%v,1) - nc = size(x%v,2) - select case(dupl) - case(psb_dupl_ovwrt_) - do i = 1, n - !loop over all val's rows - ! row actual block row - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = val(i,:) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, n - !loop over all val's rows - if ((1 <= irl(i)).and.(irl(i) <= isz)) then - ! this row belongs to me - ! copy i-th row of block val in x - x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) - end if - enddo - - case default - info = 321 - ! !$ call psb_errpush(info,name) - ! !$ goto 9999 - end select - end if - end if - call x%set_host() - if (info /= 0) then - call psb_errpush(info,'base_mlv_vect_ins') - return - end if - - end subroutine z_base_mlv_ins + interface + module subroutine z_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_ins + end interface ! !> Function base_mlv_zero @@ -2934,16 +1894,11 @@ contains !! \brief Zero out contents !! ! - subroutine z_base_mlv_zero(x) - use psi_serial_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) x%v=zzero - call x%set_host() - - end subroutine z_base_mlv_zero - + interface + module subroutine z_base_mlv_zero(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_zero + end interface ! ! Assembly. @@ -2958,81 +1913,15 @@ contains !! \param info return code !! ! - - subroutine z_base_mlv_asb(m,n, x, info, scratch) - use psi_serial_mod - use psb_realloc_mod - implicit none - integer(psb_ipk_), intent(in) :: m,n - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - logical :: scratch_ - integer(psb_ipk_) :: i, ncfs, xvsz - complex(psb_dpk_), allocatable :: vv(:,:) - - info = 0 - if (present(scratch)) then - scratch_ = scratch - else - scratch_ = .false. - end if - if (try_newins) then - if (x%is_bld()) then - ncfs = x%get_ncfs() - xvsz = psb_size(x%v) - call psb_realloc(m,n,vv,info) - vv(:,:) = zzero - select case(x%get_dupl()) - case(psb_dupl_add_) - do i=1,ncfs - vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) - end do - case(psb_dupl_ovwrt_) - do i=1,ncfs - vv(x%iv(i),:) = x%v(i,:) - end do - case(psb_dupl_err_) - do i=1,ncfs - if (any(vv(x%iv(i),:).ne.zzero)) then - info = psb_err_duplicate_coo - call psb_errpush(info,'mvect-asb') - return - else - vv(x%iv(i),:) = x%v(i,:) - end if - end do - case default - write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() - info =-7 - end select - call psb_move_alloc(vv,x%v,info) - if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.x%is_asb().or.scratch_) then - if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: @@ -3042,118 +1931,106 @@ contains !! \param info return code !! ! - subroutine z_base_mlv_free(x, info) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & - & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - - end subroutine z_base_mlv_free - - function z_base_mlv_get_ncfs(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%ncfs - end function z_base_mlv_get_ncfs - - function z_base_mlv_get_dupl(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%dupl - end function z_base_mlv_get_dupl - - function z_base_mlv_get_state(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - res = x%bldstate - end function z_base_mlv_get_state - - function z_base_mlv_is_null(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_null_) - end function z_base_mlv_is_null - - function z_base_mlv_is_bld(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_bld_) - end function z_base_mlv_is_bld - - function z_base_mlv_is_upd(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_upd_) - end function z_base_mlv_is_upd - - function z_base_mlv_is_asb(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - logical :: res - res = (x%bldstate == psb_vect_asb_) - end function z_base_mlv_is_asb - - subroutine z_base_mlv_set_ncfs(n,x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%ncfs = n - end subroutine z_base_mlv_set_ncfs - - subroutine z_base_mlv_set_dupl(n,x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%dupl = n - end subroutine z_base_mlv_set_dupl - - subroutine z_base_mlv_set_state(n,x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - x%bldstate = n - end subroutine z_base_mlv_set_state - - subroutine z_base_mlv_set_null(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_null_ - end subroutine z_base_mlv_set_null - - subroutine z_base_mlv_set_bld(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_bld_ - end subroutine z_base_mlv_set_bld - - subroutine z_base_mlv_set_upd(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_upd_ - end subroutine z_base_mlv_set_upd - - subroutine z_base_mlv_set_asb(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - x%bldstate = psb_vect_asb_ - end subroutine z_base_mlv_set_asb - + interface + module subroutine z_base_mlv_free(x, info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_free + end interface + + interface + module function z_base_mlv_get_ncfs(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_mlv_get_ncfs + end interface + + interface + module function z_base_mlv_get_dupl(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_mlv_get_dupl + end interface + + interface + module function z_base_mlv_get_state(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_mlv_get_state + end interface + + interface + module function z_base_mlv_is_null(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + end function z_base_mlv_is_null + end interface + + interface + module function z_base_mlv_is_bld(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + end function z_base_mlv_is_bld + end interface + + interface + module function z_base_mlv_is_upd(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + end function z_base_mlv_is_upd + end interface + + interface + module function z_base_mlv_is_asb(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + end function z_base_mlv_is_asb + end interface + + interface + module subroutine z_base_mlv_set_ncfs(n,x) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine z_base_mlv_set_ncfs + end interface + + interface + module subroutine z_base_mlv_set_dupl(n,x) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine z_base_mlv_set_dupl + end interface + + interface + module subroutine z_base_mlv_set_state(n,x) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + end subroutine z_base_mlv_set_state + end interface + + interface + module subroutine z_base_mlv_set_null(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_null + end interface + + interface + module subroutine z_base_mlv_set_bld(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_bld + end interface + + interface + module subroutine z_base_mlv_set_upd(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_upd + end interface + + interface + module subroutine z_base_mlv_set_asb(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_asb + end interface ! ! The base version of SYNC & friends does nothing, it's just @@ -3165,11 +2042,11 @@ contains !! \brief Sync: base version is a no-op. !! ! - subroutine z_base_mlv_sync(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - end subroutine z_base_mlv_sync + interface + module subroutine z_base_mlv_sync(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_sync + end interface ! !> Function base_mlv_set_host: @@ -3177,11 +2054,11 @@ contains !! \brief Set_host: base version is a no-op. !! ! - subroutine z_base_mlv_set_host(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - end subroutine z_base_mlv_set_host + interface + module subroutine z_base_mlv_set_host(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_host + end interface ! !> Function base_mlv_set_dev: @@ -3189,11 +2066,11 @@ contains !! \brief Set_dev: base version is a no-op. !! ! - subroutine z_base_mlv_set_dev(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - end subroutine z_base_mlv_set_dev + interface + module subroutine z_base_mlv_set_dev(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_dev + end interface ! !> Function base_mlv_set_sync: @@ -3201,11 +2078,11 @@ contains !! \brief Set_sync: base version is a no-op. !! ! - subroutine z_base_mlv_set_sync(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - end subroutine z_base_mlv_set_sync + interface + module subroutine z_base_mlv_set_sync(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3213,13 +2090,12 @@ contains !! \brief Is vector on external device . !! ! - function z_base_mlv_is_dev(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - logical :: res - - res = .false. - end function z_base_mlv_is_dev + interface + module function z_base_mlv_is_dev(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + end function z_base_mlv_is_dev + end interface ! !> Function base_mlv_is_host @@ -3227,13 +2103,12 @@ contains !! \brief Is vector on standard memory . !! ! - function z_base_mlv_is_host(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function z_base_mlv_is_host + interface + module function z_base_mlv_is_host(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + end function z_base_mlv_is_host + end interface ! !> Function base_mlv_is_sync @@ -3241,35 +2116,25 @@ contains !! \brief Is vector on sync . !! ! - function z_base_mlv_is_sync(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - logical :: res - - res = .true. - end function z_base_mlv_is_sync + interface + module function z_base_mlv_is_sync(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + end function z_base_mlv_is_sync + end interface !> Function base_cpy: !! \memberof psb_d_base_vect_type !! \brief base_cpy: copy base contents !! \param y returned variable !! - subroutine z_base_mlv_cpy(x, y) - use psi_serial_mod - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - class(psb_z_base_multivect_type), intent(out) :: y - - if (allocated(x%v)) call y%bld(x%v) - call y%set_state(x%get_state()) - call y%set_dupl(x%get_dupl()) - call y%set_ncfs(x%get_ncfs()) - if (allocated(x%iv)) y%iv = x%iv - end subroutine z_base_mlv_cpy + interface + module subroutine z_base_mlv_cpy(x, y) + class(psb_z_base_multivect_type), intent(in) :: x + class(psb_z_base_multivect_type), intent(out) :: y + end subroutine z_base_mlv_cpy + end interface - - ! ! Size info. ! ! @@ -3278,25 +2143,19 @@ contains !! \brief Number of entries !! ! - function z_base_mlv_get_nrows(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function z_base_mlv_get_nrows + interface + module function z_base_mlv_get_nrows(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_mlv_get_nrows + end interface - function z_base_mlv_get_ncols(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - integer(psb_ipk_) :: res - - res = 0 - if (allocated(x%v)) res = size(x%v,2) - - end function z_base_mlv_get_ncols + interface + module function z_base_mlv_get_ncols(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + end function z_base_mlv_get_ncols + end interface ! !> Function base_mlv_get_sizeof @@ -3304,15 +2163,12 @@ contains !! \brief Size in bytesa !! ! - function z_base_mlv_sizeof(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(in) :: x - integer(psb_epk_) :: res - - ! Force 8-byte integers. - res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() * x%get_ncols() - - end function z_base_mlv_sizeof + interface + module function z_base_mlv_sizeof(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + end function z_base_mlv_sizeof + end interface ! !> Function base_mlv_get_fmt @@ -3320,12 +2176,11 @@ contains !! \brief Format !! ! - function z_base_mlv_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'BASE' - end function z_base_mlv_get_fmt - + interface + module function z_base_mlv_get_fmt() result(res) + character(len=5) :: res + end function z_base_mlv_get_fmt + end interface ! ! @@ -3335,22 +2190,12 @@ contains !! \brief Extract a copy of the contents !! ! - function z_base_mlv_get_vect(x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - complex(psb_dpk_), allocatable :: res(:,:) - integer(psb_ipk_) :: info,m,n - m = x%get_nrows() - n = x%get_ncols() - if (.not.allocated(x%v)) return - call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') - return - end if - res(1:m,1:n) = x%v(1:m,1:n) - end function z_base_mlv_get_vect + interface + module function z_base_mlv_get_vect(x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:,:) + end function z_base_mlv_get_vect + end interface ! ! Reset all values @@ -3361,39 +2206,25 @@ contains !! \brief Set all entries !! \param val The value to set !! - subroutine z_base_mlv_set_scal(x,val) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val - - integer(psb_ipk_) :: info - x%v = val - - end subroutine z_base_mlv_set_scal - + interface + module subroutine z_base_mlv_set_scal(x,val) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + end subroutine z_base_mlv_set_scal + end interface + ! !> Function base_mlv_set_vect !! \memberof psb_z_base_multivect_type !! \brief Set all entries !! \param val(:) The vector to be copied in !! - subroutine z_base_mlv_set_vect(x,val) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_) :: nr, nc - integer(psb_ipk_) :: info - - if (allocated(x%v)) then - nr = min(size(x%v,1),size(val,1)) - nc = min(size(x%v,2),size(val,2)) - - x%v(1:nr,1:nc) = val(1:nr,1:nc) - else - x%v = val - end if - - end subroutine z_base_mlv_set_vect + interface + module subroutine z_base_mlv_set_vect(x,val) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:,:) + end subroutine z_base_mlv_set_vect + end interface ! ! Dot products @@ -3405,36 +2236,13 @@ contains !! \param n Number of entries to be considered !! \param y The other (base_mlv_vect) to be multiplied by !! - function z_base_mlv_dot_v(n,x,y) result(res) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(in) :: n - complex(psb_dpk_), allocatable :: res(:) - complex(psb_dpk_), external :: zdotc - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - res = zzero - ! - ! Note: this is the base implementation. - ! When we get here, we are sure that X is of - ! TYPE psb_z_base_mlv_vect (or its class does not care). - ! If Y is not, throw the burden on it, implicitly - ! calling dot_a - ! - select type(yy => y) - type is (psb_z_base_multivect_type) - if (y%is_dev()) call y%sync() - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = zdotc(n,x%v(:,j),1,y%v(:,j),1) - end do - class default - res = y%dot(n,x%v) - end select - - end function z_base_mlv_dot_v + interface + module function z_base_mlv_dot_v(n,x,y) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_), allocatable :: res(:) + end function z_base_mlv_dot_v + end interface ! ! Base workhorse is good old BLAS1 @@ -3446,23 +2254,14 @@ contains !! \param n Number of entries to be considered !! \param y(:) The array to be multiplied by !! - function z_base_mlv_dot_a(n,x,y) result(res) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - complex(psb_dpk_), intent(in) :: y(:,:) - integer(psb_ipk_), intent(in) :: n - complex(psb_dpk_), allocatable :: res(:) - complex(psb_dpk_), external :: zdotc - integer(psb_ipk_) :: j,nc - - if (x%is_dev()) call x%sync() - nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) - allocate(res(nc)) - do j=1,nc - res(j) = zdotc(n,x%v(:,j),1,y(:,j),1) - end do - - end function z_base_mlv_dot_a + interface + module function z_base_mlv_dot_a(n,x,y) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_), allocatable :: res(:) + end function z_base_mlv_dot_a + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3478,30 +2277,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine z_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - class(psb_z_base_multivect_type), intent(inout) :: x - class(psb_z_base_multivect_type), intent(inout) :: y - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - - if (present(n)) then - nc = n - else - nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) - end if - select type(xx => x) - type is (psb_z_base_multivect_type) - call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default - call y%axpby(m,alpha,x%v,beta,info,n=n) - end select - - end subroutine z_base_mlv_axpby_v + interface + module subroutine z_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine z_base_mlv_axpby_v + end interface ! ! AXPBY is invoked via Y, hence the structure below. @@ -3516,26 +2301,16 @@ contains !! \param beta scalar alpha !! \param info return code !! - subroutine z_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) - use psi_serial_mod - implicit none - integer(psb_ipk_), intent(in) :: m - complex(psb_dpk_), intent(in) :: x(:,:) - class(psb_z_base_multivect_type), intent(inout) :: y - complex(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: n - integer(psb_ipk_) :: nc - if (present(n)) then - nc = n - else - nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) - end if - - call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - - end subroutine z_base_mlv_axpby_a - + interface + module subroutine z_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:,:) + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + end subroutine z_base_mlv_axpby_a + end interface ! ! Multiple variants of two operations: @@ -3552,31 +2327,21 @@ contains !! \param x The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine z_base_mlv_mlt_mv(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - class(psb_z_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) + interface + module subroutine z_base_mlv_mlt_mv(x, y, info) + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_mlt_mv + end interface - end subroutine z_base_mlv_mlt_mv - - subroutine z_base_mlv_mlt_mv_v(x, y, info) - use psi_serial_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine z_base_mlv_mlt_mv_v + interface + module subroutine z_base_mlv_mlt_mv_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_mlt_mv_v + end interface ! !> Function base_mlv_mlt_ar1 @@ -3585,22 +2350,14 @@ contains !! \param x(:) The array to be multiplied by !! \param info return code !! - subroutine z_base_mlv_mlt_ar1(x, y, info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: x(:) - class(psb_z_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, n - - info = 0 - n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n - y%v(i,:) = y%v(i,:)*x(i) - end do - - end subroutine z_base_mlv_mlt_ar1 - + interface + module subroutine z_base_mlv_mlt_ar1(x, y, info) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_mlt_ar1 + end interface + ! !> Function base_mlv_mlt_ar2 !! \memberof psb_z_base_multivect_type @@ -3608,21 +2365,13 @@ contains !! \param x(:,:) The array to be multiplied by !! \param info return code !! - subroutine z_base_mlv_mlt_ar2(x, y, info) - use psi_serial_mod - implicit none - complex(psb_dpk_), intent(in) :: x(:,:) - class(psb_z_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr,nc - - info = 0 - nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) - nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) - y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - - end subroutine z_base_mlv_mlt_ar2 - + interface + module subroutine z_base_mlv_mlt_ar2(x, y, info) + complex(psb_dpk_), intent(in) :: x(:,:) + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_mlt_ar2 + end interface ! !> Function base_mlv_mlt_a_2 @@ -3635,54 +2384,16 @@ contains !! \param y(:) The array to be multiplied by !! \param info return code !! - subroutine z_base_mlv_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_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, nr, nc - - info = 0 - nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == zzero) then - if (beta == zone) then - return - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - end if - else - if (alpha == zone) then - if (beta == zzero) then - z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == zone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else if (alpha == -zone) then - if (beta == zzero) then - z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == zone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - end if - else - if (beta == zzero) then - z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == zone) then - z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else - z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - end if - end if - end if - end subroutine z_base_mlv_mlt_a_2 - + interface + module subroutine z_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_mlt_a_2 + end interface + ! !> Function base_mlv_mlt_v_2 !! \memberof psb_z_base_multivect_type @@ -3694,41 +2405,18 @@ contains !! \param y The class(base_mlv_vect) to be multiplied by !! \param info return code !! - subroutine z_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) - use psi_serial_mod - use psb_string_mod - implicit none - complex(psb_dpk_), intent(in) :: alpha,beta - class(psb_z_base_multivect_type), intent(inout) :: x - class(psb_z_base_multivect_type), intent(inout) :: y - class(psb_z_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info - character(len=1), intent(in), optional :: conjgx, conjgy - integer(psb_ipk_) :: i, n - logical :: conjgx_, conjgy_ - - info = 0 - if (x%is_dev()) call x%sync() - if (y%is_dev()) call y%sync() - if (z%is_dev()) call z%sync() - if (.not.psb_z_is_complex_) then - call z%mlt(alpha,x%v,y%v,beta,info) - else - conjgx_=.false. - if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') - conjgy_=.false. - if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - call z%mlt(alpha,x%v,y%v,beta,info) - if (conjgx_) x%v=conjg(x%v) - if (conjgy_) y%v=conjg(y%v) - end if - end subroutine z_base_mlv_mlt_v_2 + interface + module subroutine z_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_dpk_), intent(in) :: alpha,beta + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_z_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine z_base_mlv_mlt_v_2 + end interface !!$ !!$ subroutine z_base_mlv_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_base_multivect_type), intent(inout) :: y @@ -3743,8 +2431,6 @@ contains !!$ end subroutine z_base_mlv_mlt_av !!$ !!$ subroutine z_base_mlv_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_base_multivect_type), intent(inout) :: x @@ -3767,17 +2453,13 @@ contains !! \brief Scale all entries x = alpha*x !! \param alpha The multiplier !! - subroutine z_base_mlv_scal(alpha, x) - use psi_serial_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - complex(psb_dpk_), intent (in) :: alpha - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) x%v = alpha*x%v - - end subroutine z_base_mlv_scal - + interface + module subroutine z_base_mlv_scal(alpha, x) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent (in) :: alpha + end subroutine z_base_mlv_scal + end interface + ! ! Norms 1, 2 and infinity ! @@ -3785,64 +2467,40 @@ contains !! \memberof psb_z_base_multivect_type !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider - function z_base_mlv_nrm2(n,x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - real(psb_dpk_), external :: dznrm2 - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = dznrm2(n,x%v(:,j),1) - end do - - end function z_base_mlv_nrm2 + interface + module function z_base_mlv_nrm2(n,x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function z_base_mlv_nrm2 + end interface ! !> Function base_mlv_amax !! \memberof psb_z_base_multivect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider - function z_base_mlv_amax(n,x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = maxval(abs(x%v(1:n,j))) - end do - - end function z_base_mlv_amax - + interface + module function z_base_mlv_amax(n,x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function z_base_mlv_amax + end interface + ! !> Function base_mlv_asum !! \memberof psb_z_base_multivect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider - function z_base_mlv_asum(n,x) result(res) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), allocatable :: res(:) - integer(psb_ipk_) :: j, nc - - if (x%is_dev()) call x%sync() - nc = psb_size(x%v,2_psb_ipk_) - allocate(res(nc)) - do j=1,nc - res(j) = sum(abs(x%v(1:n,j))) - end do - - end function z_base_mlv_asum + interface + module function z_base_mlv_asum(n,x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + end function z_base_mlv_asum + end interface + ! ! Overwrite with absolute value ! @@ -3851,96 +2509,63 @@ contains !! \memberof psb_z_base_vect_type !! \brief Set all entries to their respective absolute values. !! - subroutine z_base_mlv_absval1(x) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - - if (allocated(x%v)) then - if (x%is_dev()) call x%sync() - x%v = abs(x%v) - call x%set_host() - end if - - end subroutine z_base_mlv_absval1 - - subroutine z_base_mlv_absval2(x,y) - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - class(psb_z_base_multivect_type), intent(inout) :: y - integer(psb_ipk_) :: info - - if (x%is_dev()) call x%sync() - if (allocated(x%v)) then - call y%axpby(min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) - call y%absval() - end if - - end subroutine z_base_mlv_absval2 - - - function z_base_mlv_use_buffer() result(res) - implicit none - logical :: res - - res = .true. - end function z_base_mlv_use_buffer - - subroutine z_base_mlv_new_buffer(n,x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: nc - nc = x%get_ncols() - call psb_realloc(n*nc,x%combuf,info) - end subroutine z_base_mlv_new_buffer - - subroutine z_base_mlv_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine z_base_mlv_new_comid - - - subroutine z_base_mlv_maybe_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine z_base_mlv_maybe_free_buffer - - subroutine z_base_mlv_free_buffer(x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine z_base_mlv_free_buffer - - subroutine z_base_mlv_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine z_base_mlv_free_comid + interface + module subroutine z_base_mlv_absval1(x) + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_absval1 + end interface + + interface + module subroutine z_base_mlv_absval2(x,y) + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + end subroutine z_base_mlv_absval2 + end interface + + + interface + module function z_base_mlv_use_buffer() result(res) + logical :: res + end function z_base_mlv_use_buffer + end interface + + interface + module subroutine z_base_mlv_new_buffer(n,x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_new_buffer + end interface + + interface + module subroutine z_base_mlv_new_comid(n,x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_new_comid + end interface + + interface + module subroutine z_base_mlv_maybe_free_buffer(x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_maybe_free_buffer + end interface + + interface + module subroutine z_base_mlv_free_buffer(x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_free_buffer + end interface + interface + module subroutine z_base_mlv_free_comid(x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_mlv_free_comid + end interface ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) @@ -3954,23 +2579,14 @@ contains !! \param idx(:) indices !! \param alpha !! \param beta - subroutine z_base_mlv_gthab(n,idx,alpha,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: alpha, beta, y(:) - class(psb_z_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - call psi_gth(n,nc,idx,alpha,x%v,beta,y) - - end subroutine z_base_mlv_gthab + interface + module subroutine z_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_base_multivect_type) :: x + end subroutine z_base_mlv_gthab + end interface ! ! shortcut alpha=1 beta=0 ! @@ -3980,19 +2596,15 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine z_base_mlv_gthzv_x(i,n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex(psb_dpk_) :: y(:) - class(psb_z_base_multivect_type) :: x - - if (x%is_dev()) call x%sync() - call x%gth(n,idx%v(i:),y) - - end subroutine z_base_mlv_gthzv_x + interface + module subroutine z_base_mlv_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_base_multivect_type) :: x + end subroutine z_base_mlv_gthzv_x + end interface ! ! shortcut alpha=1 beta=0 @@ -4003,24 +2615,14 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine z_base_mlv_gthzv(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: y(:) - class(psb_z_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine z_base_mlv_gthzv + interface + module subroutine z_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_base_multivect_type) :: x + end subroutine z_base_mlv_gthzv + end interface ! ! shortcut alpha=1 beta=0 ! @@ -4030,48 +2632,27 @@ contains !! Y = X(IDX(:)) !! \param n how many entries to consider !! \param idx(:) indices - subroutine z_base_mlv_gthzm(n,idx,x,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: y(:,:) - class(psb_z_base_multivect_type) :: x - integer(psb_mpk_) :: nc - - if (x%is_dev()) call x%sync() - if (.not.allocated(x%v)) then - return - end if - nc = psb_size(x%v,2_psb_ipk_) - - call psi_gth(n,nc,idx,x%v,y) - - end subroutine z_base_mlv_gthzm + interface + module subroutine z_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:,:) + class(psb_z_base_multivect_type) :: x + end subroutine z_base_mlv_gthzm + end interface ! ! New comm internals impl. ! - subroutine z_base_mlv_gthzbuf(i,ixb,n,idx,x) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, ixb - class(psb_i_base_vect_type) :: idx - class(psb_z_base_multivect_type) :: x - integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') - return - end if - if (idx%is_dev()) call idx%sync() - if (x%is_dev()) call x%sync() - nc = x%get_ncols() - call x%gth(n,idx%v(i:),x%combuf(ixb:)) - - end subroutine z_base_mlv_gthzbuf - + interface + module subroutine z_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_z_base_multivect_type) :: x + end subroutine z_base_mlv_gthzbuf + end interface + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -4085,72 +2666,43 @@ contains !! \param idx(:) indices !! \param beta !! \param x(:) - subroutine z_base_mlv_sctb(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: beta, x(:) - class(psb_z_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = psb_size(y%v,2_psb_ipk_) - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine z_base_mlv_sctb - - subroutine z_base_mlv_sctbr2(n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: idx(:) - complex(psb_dpk_) :: beta, x(:,:) - class(psb_z_base_multivect_type) :: y - integer(psb_mpk_) :: nc - - if (y%is_dev()) call y%sync() - nc = y%get_ncols() - call psi_sct(n,nc,idx,x,beta,y%v) - call y%set_host() - - end subroutine z_base_mlv_sctbr2 - - subroutine z_base_mlv_sctb_x(i,n,idx,x,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i - class(psb_i_base_vect_type) :: idx - complex( psb_dpk_) :: beta, x(:) - class(psb_z_base_multivect_type) :: y - - call y%sct(n,idx%v(i:),x,beta) - - end subroutine z_base_mlv_sctb_x - - subroutine z_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) - use psi_serial_mod - implicit none - integer(psb_mpk_) :: n - integer(psb_ipk_) :: i, iyb - class(psb_i_base_vect_type) :: idx - complex(psb_dpk_) :: beta - class(psb_z_base_multivect_type) :: y - integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then - call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') - return - end if - if (y%is_dev()) call y%sync() - if (idx%is_dev()) call idx%sync() - nc = y%get_ncols() - call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) - call y%set_host() - - end subroutine z_base_mlv_sctb_buf + interface + module subroutine z_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_base_multivect_type) :: y + end subroutine z_base_mlv_sctb + end interface + + interface + module subroutine z_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:,:) + class(psb_z_base_multivect_type) :: y + end subroutine z_base_mlv_sctbr2 + end interface + + interface + module subroutine z_base_mlv_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_base_multivect_type) :: y + end subroutine z_base_mlv_sctb_x + end interface + + interface + module subroutine z_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta + class(psb_z_base_multivect_type) :: y + end subroutine z_base_mlv_sctb_buf + end interface ! !> Function base_device_wait: @@ -4158,9 +2710,43 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine z_base_mlv_device_wait() - implicit none + interface + module subroutine z_base_mlv_device_wait() + end subroutine z_base_mlv_device_wait + end interface - end subroutine z_base_mlv_device_wait +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + complex(psb_dpk_) :: x(:,:) + type(psb_z_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_z_base_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(m,n,info) + + end function size_const end module psb_z_base_multivect_mod diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 062c914bb..58fb51c89 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -161,7 +161,10 @@ module psb_z_vect_mod end type psb_z_vect_type - public :: psb_z_vect + public :: psb_z_vect, psb_z_vect_type,& + & psb_z_set_vect_default, psb_z_get_vect_default, & + & psb_z_clear_vect_default, psb_z_base_vect_type + private :: constructor, size_const interface psb_z_vect module procedure constructor, size_const @@ -188,180 +191,713 @@ module psb_z_vect_mod class(psb_z_base_vect_type), allocatable, target,& & save, private :: psb_z_base_vect_default - interface psb_set_vect_default - module procedure psb_z_set_vect_default - end interface psb_set_vect_default - - interface psb_get_vect_default - module procedure psb_z_get_vect_default - end interface psb_get_vect_default - - -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 + interface + module function z_vect_get_dupl(x) result(res) + 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 + 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 + 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 + - 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 + 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 + - 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 + 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 - if (present(val)) then - x%remote_build = val - else - x%remote_build = psb_matbld_remote_ - end if - end subroutine z_vect_set_remote_build - +contains + 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 @@ -372,7 +908,6 @@ contains 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 @@ -381,7 +916,6 @@ contains 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) @@ -390,7 +924,6 @@ contains 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 @@ -401,150 +934,6 @@ contains 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,908 +955,6 @@ 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 y%v%div(x%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 y%v%div(x%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 @@ -1477,7 +964,6 @@ module psb_z_multivect_mod use psb_const_mod use psb_i_vect_mod - !private type psb_z_multivect_type @@ -1540,422 +1026,231 @@ module psb_z_multivect_mod end type psb_z_multivect_type public :: psb_z_multivect, psb_z_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default, & - & psb_z_base_multivect_type + & psb_z_set_multivect_default, psb_z_get_base_multivect_default, & + & psb_z_clear_multivect_default, psb_z_base_multivect_type - private interface psb_z_multivect module procedure constructor, size_const end interface psb_z_multivect + private + 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 - + 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 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 - 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 + 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 + integer(psb_ipk_) :: info + end subroutine z_mvect_cnv + end interface -!!$ function z_mvect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ module function z_mvect_dot_v(n,x,y) result(res) !!$ class(psb_z_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_dpk_) :: res @@ -1967,7 +1262,6 @@ contains !!$ end function z_mvect_dot_v !!$ !!$ 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 @@ -1979,9 +1273,7 @@ contains !!$ !!$ end function z_mvect_dot_a !!$ -!!$ subroutine z_mvect_axpby_v(m,alpha, x, beta, y, info) -!!$ use psi_serial_mod -!!$ implicit none +!!$ module subroutine z_mvect_axpby_v(m,alpha, x, beta, y, info) !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: y @@ -1997,8 +1289,6 @@ contains !!$ end subroutine z_mvect_axpby_v !!$ !!$ 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 @@ -2012,8 +1302,6 @@ contains !!$ !!$ !!$ 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 @@ -2026,8 +1314,6 @@ contains !!$ end subroutine z_mvect_mlt_v !!$ !!$ 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 @@ -2042,8 +1328,6 @@ contains !!$ !!$ !!$ 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(:) @@ -2058,8 +1342,6 @@ contains !!$ end subroutine z_mvect_mlt_a_2 !!$ !!$ 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 @@ -2077,8 +1359,6 @@ contains !!$ end subroutine z_mvect_mlt_v_2 !!$ !!$ 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 @@ -2093,8 +1373,6 @@ contains !!$ end subroutine z_mvect_mlt_av !!$ !!$ 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 @@ -2110,8 +1388,6 @@ contains !!$ end subroutine z_mvect_mlt_va !!$ !!$ 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 !!$ @@ -2121,7 +1397,6 @@ contains !!$ !!$ !!$ 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 @@ -2135,7 +1410,6 @@ contains !!$ end function z_mvect_nrm2 !!$ !!$ 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 @@ -2149,7 +1423,6 @@ contains !!$ end function z_mvect_amax !!$ !!$ 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 @@ -2162,4 +1435,65 @@ contains !!$ !!$ end function z_mvect_asum +contains + + subroutine psb_z_set_multivect_default(v) + 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) +!!$ 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) + 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 + + 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 + + + subroutine psb_z_clear_multivect_default() + + if (allocated(psb_z_base_multivect_default)) then + deallocate(psb_z_base_multivect_default) + end if + + end subroutine psb_z_clear_multivect_default + end module psb_z_multivect_mod diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index 37f400f05..eb9952b61 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -8,23 +8,25 @@ BOBJS=psb_base_mat_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 SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o\ - psb_s_rb_idx_tree_impl.o + psb_s_rb_idx_tree_impl.o psb_s_base_vect_impl.o psb_s_vect_impl.o #\ psb_s_lcoo_impl.o psb_s_lcsr_impl.o DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o\ - psb_d_rb_idx_tree_impl.o + psb_d_rb_idx_tree_impl.o psb_d_base_vect_impl.o psb_d_vect_impl.o #\ psb_d_lcoo_impl.o psb_d_lcsr_impl.o COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o\ - psb_c_rb_idx_tree_impl.o + psb_c_rb_idx_tree_impl.o psb_c_base_vect_impl.o psb_c_vect_impl.o #\ psb_c_lcoo_impl.o psb_c_lcsr_impl.o ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o\ - psb_z_rb_idx_tree_impl.o + psb_z_rb_idx_tree_impl.o psb_z_base_vect_impl.o psb_z_vect_impl.o #\ psb_z_lcoo_impl.o psb_z_lcsr_impl.o +IOBJS=psb_i_base_vect_impl.o psb_i_vect_impl.o +LOBJS=psb_l_base_vect_impl.o psb_l_vect_impl.o -OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) +OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) $(IOBJS) $(LOBJS) # # Where the library should go, and how it is called. diff --git a/base/serial/impl/psb_c_base_vect_impl.F90 b/base/serial/impl/psb_c_base_vect_impl.F90 new file mode 100644 index 000000000..e33fc88d6 --- /dev/null +++ b/base/serial/impl/psb_c_base_vect_impl.F90 @@ -0,0 +1,3596 @@ +! +! 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_base_vect_mod +! +! This module contains the definition of the psb_c_base_vect type which +! is a container for dense vectors. +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +submodule (psb_c_base_vect_mod) psb_c_base_vect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_c_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine c_base_bld_x(x,this,scratch) + complex(psb_spk_), intent(in) :: this(:) + class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + integer(psb_ipk_) :: i + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if +#if defined (PSB_OPENMP) + !$omp parallel do private(i) + do i = 1, size(this) + x%v(i) = this(i) + end do +#else + x%v(:) = this(:) +#endif + end subroutine c_base_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_c_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine c_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine c_base_bld_mn + + + !> Function bld_en: + !! \memberof psb_c_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine c_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine c_base_bld_en + + + !> Function base_all: + !! \memberof psb_c_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine c_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_c_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine c_base_all + + + !> Function base_mold: + !! \memberof psb_c_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine c_base_mold(x, y, info) + class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_c_base_vect_type :: y, stat=info) + + end subroutine c_base_mold + + + module subroutine c_base_reinit(x, info,clear) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + logical :: clear_ + + info = 0 + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + if (clear_) x%v(:) = czero + call x%set_host() + call x%set_upd() + end if + + end subroutine c_base_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_c_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine c_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine c_base_ins_a + + + module subroutine c_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_c_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,maxr,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine c_base_ins_v + + + + ! + !> Function base_zero + !! \memberof psb_c_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine c_base_zero(x) + class(psb_c_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) then + !$omp workshare + x%v(:)=czero + !$omp end workshare + end if + call x%set_host() + end subroutine c_base_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_c_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine c_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_spk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = czero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne. czero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine c_base_asb_m + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_c_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine c_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_spk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = czero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne. czero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine c_base_asb_e + + + ! + !> Function base_free: + !! \memberof psb_c_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine c_base_free(x, info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) + if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + call x%set_null() + end subroutine c_base_free + + + ! + !> Function base_free_buffer: + !! \memberof psb_c_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + module subroutine c_base_free_buffer(x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine c_base_free_buffer + + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_c_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + module subroutine c_base_maybe_free_buffer(x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine c_base_maybe_free_buffer + + + ! + !> Function base_free_comid: + !! \memberof psb_c_base_vect_type + !! \brief Free aux MPI communication id buffer + !! + !! \param info return code + !! + ! + module subroutine c_base_free_comid(x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine c_base_free_comid + + + module function c_base_get_ncfs(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function c_base_get_ncfs + + module function c_base_get_dupl(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function c_base_get_dupl + + module function c_base_get_state(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function c_base_get_state + + module function c_base_is_null(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function c_base_is_null + + module function c_base_is_bld(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function c_base_is_bld + + module function c_base_is_upd(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function c_base_is_upd + + module function c_base_is_asb(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function c_base_is_asb + + module subroutine c_base_set_ncfs(n,x) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine c_base_set_ncfs + + + module subroutine c_base_set_dupl(n,x) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine c_base_set_dupl + + + module subroutine c_base_set_state(n,x) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine c_base_set_state + + + module subroutine c_base_set_null(x) + class(psb_c_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine c_base_set_null + + + module subroutine c_base_set_bld(x) + class(psb_c_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine c_base_set_bld + + + module subroutine c_base_set_upd(x) + class(psb_c_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine c_base_set_upd + + + module subroutine c_base_set_asb(x) + class(psb_c_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine c_base_set_asb + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_c_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine c_base_sync(x) + class(psb_c_base_vect_type), intent(inout) :: x + + end subroutine c_base_sync + + + ! + !> Function base_set_host: + !! \memberof psb_c_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine c_base_set_host(x) + class(psb_c_base_vect_type), intent(inout) :: x + + end subroutine c_base_set_host + + + ! + !> Function base_set_dev: + !! \memberof psb_c_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine c_base_set_dev(x) + class(psb_c_base_vect_type), intent(inout) :: x + + end subroutine c_base_set_dev + + + ! + !> Function base_set_sync: + !! \memberof psb_c_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine c_base_set_sync(x) + class(psb_c_base_vect_type), intent(inout) :: x + + end subroutine c_base_set_sync + + + ! + !> Function base_is_dev: + !! \memberof psb_c_base_vect_type + !! \brief Is vector on external device . + !! + ! + module function c_base_is_dev(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function c_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_c_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + module function c_base_is_host(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function c_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_c_base_vect_type + !! \brief Is vector on sync . + !! + ! + module function c_base_is_sync(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function c_base_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine c_base_cpy(x, y) + class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine c_base_cpy + + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_c_base_vect_type + !! \brief Number of entries + !! + ! + module function c_base_get_nrows(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function c_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_c_base_vect_type + !! \brief Size in bytes + !! + ! + module function c_base_sizeof(x) result(res) + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() + + end function c_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_c_base_vect_type + !! \brief Format + !! + ! + module function c_base_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function c_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_c_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + module function c_base_get_vect(x,n) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz, i + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + if (.false.) then + res(1:isz) = x%v(1:isz) + else + !$omp parallel do private(i) + do i=1, isz + res(i) = x%v(i) + end do + end if + + end function c_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_c_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine c_base_set_scal(x,val,first,last) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val + end do +#else + x%v(first_:last_) = val +#endif + call x%set_host() + + end subroutine c_base_set_scal + + + + ! + !> Function base_set_vect + !! \memberof psb_c_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine c_base_set_vect(x,val,first,last) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i, info + + if (.not.allocated(x%v)) then + call psb_realloc(size(val),x%v,info) + end if + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val(i-first_+1) + end do +#else + x%v(first_:last_) = val(1:last_-first_+1) +#endif + call x%set_host() + + end subroutine c_base_set_vect + + + module subroutine c_base_check_addr(x) + class(psb_c_base_vect_type), intent(inout) :: x + + write(0,*) 'Check addr: base version, do nothing' + + end subroutine c_base_check_addr + + + + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_c_base_vect_type + !! \brief Get one entry from the vector + !! + ! + module function c_base_get_entry(x, index) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: res + + res = czero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if + + end function c_base_get_entry + + module subroutine c_base_set_entry(x, index, val) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + end subroutine c_base_set_entry + + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_c_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine c_base_absval1(x) + class(psb_c_base_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: i + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1, size(x%v) + x%v(i) = abs(x%v(i)) + end do +#else + x%v = abs(x%v) +#endif + call x%set_host() + end if + + end subroutine c_base_absval1 + + + module subroutine c_base_absval2(x,y) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_) :: info + if (.not.x%is_host()) call x%sync() + if (allocated(x%v)) then + call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) + call y%absval() + end if + + end subroutine c_base_absval2 + + + ! + ! Dot products + ! + ! + !> Function base_dot_v + !! \memberof psb_c_base_vect_type + !! \brief Dot product by another base_vector + !! \param n Number of entries to be considered + !! \param y The other (base_vect) to be multiplied by + !! + module function c_base_dot_v(n,x,y) result(res) + class(psb_c_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + complex(psb_spk_), external :: cdotc + + res = czero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_c_base_vect. + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_c_base_vect_type) + res = cdotc(n,x%v,1,y%v,1) + class default + res = y%dot(n,x%v) + end select + + end function c_base_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_dot_a + !! \memberof psb_c_base_vect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function c_base_dot_a(n,x,y) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_) :: res + complex(psb_spk_), external :: cdotc + + res = cdotc(n,y,1,x%v,1) + + end function c_base_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_axpby_v + !! \memberof psb_c_base_vect_type + !! \brief AXPBY by a (base_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine c_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call y%axpby(m,alpha,x%v,beta,info) + + end subroutine c_base_axpby_v + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_c_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + module subroutine c_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine c_base_axpby_v2 + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_axpby_a + !! \memberof psb_c_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine c_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (y%is_dev()) call y%sync() + call psb_geaxpby(m,alpha,x,beta,y%v,info) + call y%set_host() + + end subroutine c_base_axpby_a + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_c_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + module subroutine c_base_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_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine c_base_axpby_a2 + + + ! + ! UPD_XYZ is invoked via Z, hence the structure below. + ! + ! + !> Function base_upd_xyz + !! \memberof psb_c_base_vect_type + !! \brief UPD_XYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param beta scalar beta + !! \param gamma scalar gamma + !! \param delta scalar delta + !! \param x The class(base_vect) to be added + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be added + !! \param info return code + !! + module subroutine c_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(alpha/=czero)) call x%sync() + if (y%is_dev().and.(beta/=czero)) call y%sync() + if (z%is_dev().and.(delta/=czero)) call z%sync() + call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) + call y%set_host() + call z%set_host() + + end subroutine c_base_upd_xyz + + + module subroutine c_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + class(psb_c_base_vect_type), intent(inout) :: w + complex(psb_spk_), intent (in) :: a,b,c,d,e,f + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(a/=czero)) call x%sync() + if (y%is_dev().and.(b/=czero)) call y%sync() + if (z%is_dev().and.(d/=czero)) call z%sync() + if (w%is_dev().and.(f/=czero)) call w%sync() + call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) + call y%set_host() + call z%set_host() + call w%set_host() + + end subroutine c_base_xyzw + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:) = X(:)*Y(:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlt_a + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry multiply by a base_vect array y=x*y + !! \param x The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlt_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine c_base_mlt_v + + + ! + !> Function base_mlt_a + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry multiply by a normal array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlt_a(x, y, info) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)*x(i) + end do + call y%set_host() + + end subroutine c_base_mlt_a + + + + ! + !> Function base_mlt_a_2 + !! \memberof psb_c_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine c_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(z%v), size(x), size(y)) + if (alpha == czero) then + if (beta == cone) then + return + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + end do + end if + else + if (alpha == cone) then + if (beta == czero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = y(i)*x(i) + end do + else if (beta == cone) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) + y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + y(i)*x(i) + end do + end if + else if (alpha == -cone) then + if (beta == czero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = -y(i)*x(i) + end do + else if (beta == cone) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) - y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) - y(i)*x(i) + end do + end if + else + if (beta == czero) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = alpha*y(i)*x(i) + end do + else if (beta == cone) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = z%v(i) + alpha*y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(alpha, beta) + do i=1, n + z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) + end do + end if + end if + end if + call z%set_host() + + end subroutine c_base_mlt_a_2 + + + ! + !> Function base_mlt_v_2 + !! \memberof psb_c_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_vect) to be multiplied b + !! \param y The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_spk_), intent(in) :: alpha,beta + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (y%is_dev()) call y%sync() + if (x%is_dev()) call x%sync() + if (.not.psb_c_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + end if + end subroutine c_base_mlt_v_2 + + + module subroutine c_base_mlt_av(alpha,x,y,beta,z,info) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call z%mlt(alpha,x,y%v,beta,info) + + end subroutine c_base_mlt_av + + + module subroutine c_base_mlt_va(alpha,x,y,beta,z,info) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call z%mlt(alpha,y,x,beta,info) + + end subroutine c_base_mlt_va + + ! + !> Function base_div_v + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine c_base_div_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%div(x%v,info) + + end subroutine c_base_div_v + + + module subroutine c_base_div_a(x, y, info) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)/x(i) + end do + call y%set_host() + + end subroutine c_base_div_a + + ! + !> Function base_div_v2 + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine c_base_div_v2(x, y, z, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call z%div(x%v,y%v,info) + call z%set_host() + end subroutine c_base_div_v2 + + ! + !> Function base_div_v_check + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine c_base_div_v_check(x, y, info, flag) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call x%div(x%v,y%v,info,flag) + + end subroutine c_base_div_v_check + + ! + !> Function base_div_v2_check + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine c_base_div_v2_check(x, y, z, info, flag) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + end subroutine c_base_div_v2_check + + ! + !> Function base_div_a2 + !! \memberof psb_c_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + module subroutine c_base_div_a2(x, y, z, info) + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + !$omp parallel do private(i) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine c_base_div_a2 + + ! + !> Function base_div_a2_check + !! \memberof psb_c_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + module subroutine c_base_div_a2_check(x, y, z, info, flag) + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call c_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + ! $omp parallel do private(i) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine c_base_div_a2_check + + ! + !> Function base_inv_v + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + module subroutine c_base_inv_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine c_base_inv_v + + ! + !> Function base_inv_v_check + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + module subroutine c_base_inv_v_check(x, y, info, flag) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + end subroutine c_base_inv_v_check + + ! + !> Function base_inv_a2 + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + module subroutine c_base_inv_a2(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + y%v(i) = 1_psb_spk_/x(i) + end do + + end subroutine c_base_inv_a2 + + ! + !> Function base_inv_a2_check + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + module subroutine c_base_inv_a2_check(x, y, info, flag) + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call c_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_spk_/x(i) + else + info = 1 + y%v(i) = 0_psb_spk_ + end if + end do + end if + + + end subroutine c_base_inv_a2_check + + + ! + !> Function base_inv_a2_check + !! \memberof psb_c_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine c_base_acmp_a2(x,c,z,info) + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + !$omp parallel do private(i) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_spk_ + else + z%v(i) = 0_psb_spk_ + end if + end do + info = 0 + + end subroutine c_base_acmp_a2 + + ! + !> Function base_cmp_v2 + !! \memberof psb_c_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine c_base_acmp_v2(x,c,z,info) + class(psb_c_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine c_base_acmp_v2 + + + ! + ! Simple scaling + ! + !> Function base_scal + !! \memberof psb_c_base_vect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! + module subroutine c_base_scal(alpha, x) + class(psb_c_base_vect_type), intent(inout) :: x + complex(psb_spk_), intent (in) :: alpha + integer(psb_ipk_) :: i + + if (allocated(x%v)) then +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1,size(x%v) + x%v(i) = alpha*x%v(i) + end do +#else + x%v = alpha*x%v +#endif + end if + call x%set_host() + end subroutine c_base_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_nrm2 + !! \memberof psb_c_base_vect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function c_base_nrm2(n,x) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + real(psb_spk_), external :: scnrm2 + + if (x%is_dev()) call x%sync() + res = scnrm2(n,x%v,1) + + end function c_base_nrm2 + + ! + !> Function base_amax + !! \memberof psb_c_base_vect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function c_base_amax(n,x) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res = szero + !$omp parallel do private(i) reduction(max: res) + do i=1, n + res = max(res,abs(x%v(i))) + end do +#else + res = maxval(abs(x%v(1:n))) +#endif + end function c_base_amax + + + ! + !> Function base_asum + !! \memberof psb_c_base_vect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function c_base_asum(n,x) result(res) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res=szero + !$omp parallel do private(i) reduction(+: res) + do i= 1, size(x%v) + res = res + abs(x%v(i)) + end do +#else + res = sum(abs(x%v(1:n))) +#endif + end function c_base_asum + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_c_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine c_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine c_base_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_c_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine c_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: y(:) + class(psb_c_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine c_base_gthzv_x + + + ! + ! New comm internals impl. + ! + module subroutine c_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_c_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine c_base_gthzbuf + + ! + !> Function base_device_wait: + !! \memberof psb_c_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine c_base_device_wait() + + end subroutine c_base_device_wait + + + module function c_base_use_buffer() result(res) + logical :: res + + res = .true. + end function c_base_use_buffer + + module subroutine c_base_new_buffer(n,x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine c_base_new_buffer + + + module subroutine c_base_new_comid(n,x,info) + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine c_base_new_comid + + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_c_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine c_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine c_base_gthzv + + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_c_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine c_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine c_base_sctb + + + module subroutine c_base_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_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine c_base_sctb_x + + + module subroutine c_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta + class(psb_c_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine c_base_sctb_buf + + + + ! + !> Function _base_addconst_a2 + !! \memberof psb_c_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine c_base_addconst_a2(x,b,z,info) + real(psb_spk_), intent(in) :: b + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() +#if defined(PSB_OPENMP) + n = size(x) + !$omp parallel do private(i) + do i = 1, n + z%v(i) = x(i) + b + end do +#else + z%v = x + b +#endif + info = 0 + + end subroutine c_base_addconst_a2 + + ! + !> Function _base_addconst_v2 + !! \memberof psb_c_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine c_base_addconst_v2(x,b,z,info) + class(psb_c_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: b + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine c_base_addconst_v2 + +end submodule psb_c_base_vect_impl + + +submodule (psb_c_base_multivect_mod) psb_c_base_multivect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_c_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine c_base_mlv_bld_x(x,this) + complex(psb_spk_), intent(in) :: this(:,:) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine c_base_mlv_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_c_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine c_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info,scratch=scratch) + + end subroutine c_base_mlv_bld_n + + + !> Function base_mlv_all: + !! \memberof psb_c_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine c_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine c_base_mlv_all + + + !> Function base_mlv_mold: + !! \memberof psb_c_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine c_base_mlv_mold(x, y, info) + class(psb_c_base_multivect_type), intent(in) :: x + class(psb_c_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_c_base_multivect_type :: y, stat=info) + + end subroutine c_base_mlv_mold + + + module subroutine c_base_mlv_reinit(x, info) + class(psb_c_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = czero + call x%set_host() + call x%set_upd() + end if + + end subroutine c_base_mlv_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_c_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine c_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine c_base_mlv_ins + + + ! + !> Function base_mlv_zero + !! \memberof psb_c_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine c_base_mlv_zero(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=czero + call x%set_host() + + end subroutine c_base_mlv_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_c_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine c_base_mlv_asb(m,n, x, info, scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_spk_), allocatable :: vv(:,:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(m,n,vv,info) + vv(:,:) = czero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i),:) = x%v(i,:) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (any(vv(x%iv(i),:).ne.czero)) then + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') + return + else + vv(x%iv(i),:) = x%v(i,:) + end if + end do + case default + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_c_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine c_base_mlv_free(x, info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine c_base_mlv_free + + + module function c_base_mlv_get_ncfs(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function c_base_mlv_get_ncfs + + module function c_base_mlv_get_dupl(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function c_base_mlv_get_dupl + + module function c_base_mlv_get_state(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function c_base_mlv_get_state + + module function c_base_mlv_is_null(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function c_base_mlv_is_null + + module function c_base_mlv_is_bld(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function c_base_mlv_is_bld + + module function c_base_mlv_is_upd(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function c_base_mlv_is_upd + + module function c_base_mlv_is_asb(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function c_base_mlv_is_asb + + module subroutine c_base_mlv_set_ncfs(n,x) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine c_base_mlv_set_ncfs + + + module subroutine c_base_mlv_set_dupl(n,x) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine c_base_mlv_set_dupl + + + module subroutine c_base_mlv_set_state(n,x) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine c_base_mlv_set_state + + + module subroutine c_base_mlv_set_null(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine c_base_mlv_set_null + + + module subroutine c_base_mlv_set_bld(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine c_base_mlv_set_bld + + + module subroutine c_base_mlv_set_upd(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine c_base_mlv_set_upd + + + module subroutine c_base_mlv_set_asb(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine c_base_mlv_set_asb + + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_c_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine c_base_mlv_sync(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + end subroutine c_base_mlv_sync + + + ! + !> Function base_mlv_set_host: + !! \memberof psb_c_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine c_base_mlv_set_host(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + end subroutine c_base_mlv_set_host + + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_c_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine c_base_mlv_set_dev(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + end subroutine c_base_mlv_set_dev + + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_c_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine c_base_mlv_set_sync(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + end subroutine c_base_mlv_set_sync + + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_c_base_multivect_type + !! \brief Is vector on external device . + !! + ! + module function c_base_mlv_is_dev(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function c_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_c_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + module function c_base_mlv_is_host(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function c_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_c_base_multivect_type + !! \brief Is vector on sync . + !! + ! + module function c_base_mlv_is_sync(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function c_base_mlv_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine c_base_mlv_cpy(x, y) + class(psb_c_base_multivect_type), intent(in) :: x + class(psb_c_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine c_base_mlv_cpy + + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_c_base_multivect_type + !! \brief Number of entries + !! + ! + module function c_base_mlv_get_nrows(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function c_base_mlv_get_nrows + + module function c_base_mlv_get_ncols(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function c_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_c_base_multivect_type + !! \brief Size in bytesa + !! + ! + module function c_base_mlv_sizeof(x) result(res) + class(psb_c_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() * x%get_ncols() + + end function c_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_c_base_multivect_type + !! \brief Format + !! + ! + module function c_base_mlv_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function c_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_c_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + module function c_base_mlv_get_vect(x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function c_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_c_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine c_base_mlv_set_scal(x,val) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine c_base_mlv_set_scal + + + ! + !> Function base_mlv_set_vect + !! \memberof psb_c_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine c_base_mlv_set_vect(x,val) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine c_base_mlv_set_vect + + + ! + ! Dot products + ! + ! + !> Function base_mlv_dot_v + !! \memberof psb_c_base_multivect_type + !! \brief Dot product by another base_mlv_vector + !! \param n Number of entries to be considered + !! \param y The other (base_mlv_vect) to be multiplied by + !! + module function c_base_mlv_dot_v(n,x,y) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_), allocatable :: res(:) + complex(psb_spk_), external :: cdotc + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + res = czero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_c_base_mlv_vect (or its class does not care). + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_c_base_multivect_type) + if (y%is_dev()) call y%sync() + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = cdotc(n,x%v(:,j),1,y%v(:,j),1) + end do + class default + res = y%dot(n,x%v) + end select + + end function c_base_mlv_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_mlv_dot_a + !! \memberof psb_c_base_multivect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function c_base_mlv_dot_a(n,x,y) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + complex(psb_spk_), allocatable :: res(:) + complex(psb_spk_), external :: cdotc + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = cdotc(n,x%v(:,j),1,y(:,j),1) + end do + + end function c_base_mlv_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_mlv_axpby_v + !! \memberof psb_c_base_multivect_type + !! \brief AXPBY by a (base_mlv_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_mlv_vect) to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine c_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + + if (present(n)) then + nc = n + else + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + end if + select type(xx => x) + type is (psb_c_base_multivect_type) + call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) + class default + call y%axpby(m,alpha,x%v,beta,info,n=n) + end select + + end subroutine c_base_mlv_axpby_v + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_mlv_axpby_a + !! \memberof psb_c_base_multivect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine c_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:,:) + class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + if (present(n)) then + nc = n + else + nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) + end if + + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) + + end subroutine c_base_mlv_axpby_a + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlv_mlt_mv + !! \memberof psb_c_base_multivect_type + !! \brief Multivector entry-by-entry multiply by a base_mlv_multivect y=x*y + !! \param x The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlv_mlt_mv(x, y, info) + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine c_base_mlv_mlt_mv + + + module subroutine c_base_mlv_mlt_mv_v(x, y, info) + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine c_base_mlv_mlt_mv_v + + + ! + !> Function base_mlv_mlt_ar1 + !! \memberof psb_c_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 1 array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlv_mlt_ar1(x, y, info) + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + n = min(psb_size(y%v,1_psb_ipk_), size(x)) + do i=1, n + y%v(i,:) = y%v(i,:)*x(i) + end do + + end subroutine c_base_mlv_mlt_ar1 + + + ! + !> Function base_mlv_mlt_ar2 + !! \memberof psb_c_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 2 array y=x*y + !! \param x(:,:) The array to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlv_mlt_ar2(x, y, info) + complex(psb_spk_), intent(in) :: x(:,:) + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr,nc + + info = 0 + nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) + nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) + y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) + + end subroutine c_base_mlv_mlt_ar2 + + + + ! + !> Function base_mlv_mlt_a_2 + !! \memberof psb_c_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr, nc + + info = 0 + nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == czero) then + if (beta == cone) then + return + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + end if + else + if (alpha == cone) then + if (beta == czero) then + z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == cone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else if (alpha == -cone) then + if (beta == czero) then + z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == cone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else + if (beta == czero) then + z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == cone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + end if + end if + end if + end subroutine c_base_mlv_mlt_a_2 + + + ! + !> Function base_mlv_mlt_v_2 + !! \memberof psb_c_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_mlv_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_mlv_vect) to be multiplied b + !! \param y The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine c_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_spk_), intent(in) :: alpha,beta + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_c_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + if (z%is_dev()) call z%sync() + if (.not.psb_c_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + end if + end subroutine c_base_mlv_mlt_v_2 + +!!$ +!!$ subroutine c_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ complex(psb_spk_), intent(in) :: alpha,beta +!!$ complex(psb_spk_), intent(in) :: x(:) +!!$ class(psb_c_base_multivect_type), intent(inout) :: y +!!$ class(psb_c_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine c_base_mlv_mlt_av + +!!$ +!!$ subroutine c_base_mlv_mlt_va(alpha,x,y,beta,z,info) +!!$ complex(psb_spk_), intent(in) :: alpha,beta +!!$ complex(psb_spk_), intent(in) :: y(:) +!!$ class(psb_c_base_multivect_type), intent(inout) :: x +!!$ class(psb_c_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,y,x,beta,info) +!!$ +!!$ end subroutine c_base_mlv_mlt_va + +!!$ +!!$ + ! + ! Simple scaling + ! + !> Function base_mlv_scal + !! \memberof psb_c_base_multivect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! +module subroutine c_base_mlv_scal(alpha, x) + class(psb_c_base_multivect_type), intent(inout) :: x + complex(psb_spk_), intent (in) :: alpha + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) x%v = alpha*x%v + + end subroutine c_base_mlv_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_mlv_nrm2 + !! \memberof psb_c_base_multivect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function c_base_mlv_nrm2(n,x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + real(psb_spk_), external :: scnrm2 + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = scnrm2(n,x%v(:,j),1) + end do + + end function c_base_mlv_nrm2 + + + ! + !> Function base_mlv_amax + !! \memberof psb_c_base_multivect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function c_base_mlv_amax(n,x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = maxval(abs(x%v(1:n,j))) + end do + + end function c_base_mlv_amax + + + ! + !> Function base_mlv_asum + !! \memberof psb_c_base_multivect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function c_base_mlv_asum(n,x) result(res) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = sum(abs(x%v(1:n,j))) + end do + + end function c_base_mlv_asum + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_c_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine c_base_mlv_absval1(x) + class(psb_c_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v = abs(x%v) + call x%set_host() + end if + + end subroutine c_base_mlv_absval1 + + + module subroutine c_base_mlv_absval2(x,y) + class(psb_c_base_multivect_type), intent(inout) :: x + class(psb_c_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) then + call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) + call y%absval() + end if + + end subroutine c_base_mlv_absval2 + + + + module function c_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function c_base_mlv_use_buffer + + + module subroutine c_base_mlv_new_buffer(n,x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine c_base_mlv_new_buffer + + + module subroutine c_base_mlv_new_comid(n,x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine c_base_mlv_new_comid + + + + module subroutine c_base_mlv_maybe_free_buffer(x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine c_base_mlv_maybe_free_buffer + + + module subroutine c_base_mlv_free_buffer(x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine c_base_mlv_free_buffer + + + module subroutine c_base_mlv_free_comid(x,info) + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine c_base_mlv_free_comid + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_c_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine c_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine c_base_mlv_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_c_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine c_base_mlv_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_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine c_base_mlv_gthzv_x + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_c_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine c_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine c_base_mlv_gthzv + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_c_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine c_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: y(:,:) + class(psb_c_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine c_base_mlv_gthzm + + + ! + ! New comm internals impl. + ! + module subroutine c_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_c_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine c_base_mlv_gthzbuf + + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_c_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine c_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine c_base_mlv_sctb + + + module subroutine c_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_spk_) :: beta, x(:,:) + class(psb_c_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine c_base_mlv_sctbr2 + + + module subroutine c_base_mlv_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_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine c_base_mlv_sctb_x + + + module subroutine c_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta + class(psb_c_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine c_base_mlv_sctb_buf + + + ! + !> Function base_device_wait: + !! \memberof psb_c_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine c_base_mlv_device_wait() + + end subroutine c_base_mlv_device_wait + +end submodule psb_c_base_multivect_impl 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 000000000..b72df85b2 --- /dev/null +++ b/base/serial/impl/psb_c_vect_impl.F90 @@ -0,0 +1,1629 @@ +! +! 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 psb_base_mod + use psi_serial_mod + implicit none + +contains + + module function c_vect_get_dupl(x) result(res) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + + 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) + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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%div(x%v,info) + + end subroutine c_vect_div_v + + 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 + 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) + 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%div(x%v,info,flag) + + end subroutine c_vect_div_v_check + + 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 + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 psb_base_mod + use psi_serial_mod + +contains + + module function c_mvect_get_dupl(x) result(res) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + 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) + + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) +!!$ 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 +!!$ +!!$ function c_mvect_dot_a(n,x,y) result(res) +!!$ 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) +!!$ 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 +!!$ +!!$ subroutine c_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine c_mvect_mlt_v(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 +!!$ 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 +!!$ +!!$ subroutine c_mvect_mlt_a(x, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine c_mvect_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_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 +!!$ +!!$ subroutine c_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ 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 +!!$ +!!$ subroutine c_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine c_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine c_mvect_scal(alpha, x) +!!$ 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 +!!$ +!!$ +!!$ function c_mvect_nrm2(n,x) result(res) +!!$ 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 +!!$ +!!$ function c_mvect_amax(n,x) result(res) +!!$ 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 +!!$ +!!$ function c_mvect_asum(n,x) result(res) +!!$ 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 new file mode 100644 index 000000000..2e817721f --- /dev/null +++ b/base/serial/impl/psb_d_base_vect_impl.F90 @@ -0,0 +1,3765 @@ +! +! 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_base_vect_mod +! +! This module contains the definition of the psb_d_base_vect type which +! is a container for dense vectors. +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +submodule (psb_d_base_vect_mod) psb_d_base_vect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_d_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine d_base_bld_x(x,this,scratch) + real(psb_dpk_), intent(in) :: this(:) + class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + integer(psb_ipk_) :: i + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if +#if defined (PSB_OPENMP) + !$omp parallel do private(i) + do i = 1, size(this) + x%v(i) = this(i) + end do +#else + x%v(:) = this(:) +#endif + end subroutine d_base_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_d_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine d_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine d_base_bld_mn + + + !> Function bld_en: + !! \memberof psb_d_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine d_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine d_base_bld_en + + + !> Function base_all: + !! \memberof psb_d_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine d_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_d_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine d_base_all + + + !> Function base_mold: + !! \memberof psb_d_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine d_base_mold(x, y, info) + class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_d_base_vect_type :: y, stat=info) + + end subroutine d_base_mold + + + module subroutine d_base_reinit(x, info,clear) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + logical :: clear_ + + info = 0 + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + if (clear_) x%v(:) = dzero + call x%set_host() + call x%set_upd() + end if + + end subroutine d_base_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_d_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine d_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine d_base_ins_a + + + module subroutine d_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_d_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,maxr,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine d_base_ins_v + + + + ! + !> Function base_zero + !! \memberof psb_d_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine d_base_zero(x) + class(psb_d_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) then + !$omp workshare + x%v(:)=dzero + !$omp end workshare + end if + call x%set_host() + end subroutine d_base_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_d_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine d_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_dpk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne. dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine d_base_asb_m + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_d_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine d_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_dpk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne. dzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine d_base_asb_e + + + ! + !> Function base_free: + !! \memberof psb_d_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine d_base_free(x, info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) + if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + call x%set_null() + end subroutine d_base_free + + + ! + !> Function base_free_buffer: + !! \memberof psb_d_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + module subroutine d_base_free_buffer(x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine d_base_free_buffer + + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_d_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + module subroutine d_base_maybe_free_buffer(x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine d_base_maybe_free_buffer + + + ! + !> Function base_free_comid: + !! \memberof psb_d_base_vect_type + !! \brief Free aux MPI communication id buffer + !! + !! \param info return code + !! + ! + module subroutine d_base_free_comid(x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine d_base_free_comid + + + module function d_base_get_ncfs(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function d_base_get_ncfs + + module function d_base_get_dupl(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function d_base_get_dupl + + module function d_base_get_state(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function d_base_get_state + + module function d_base_is_null(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function d_base_is_null + + module function d_base_is_bld(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function d_base_is_bld + + module function d_base_is_upd(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function d_base_is_upd + + module function d_base_is_asb(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function d_base_is_asb + + module subroutine d_base_set_ncfs(n,x) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine d_base_set_ncfs + + + module subroutine d_base_set_dupl(n,x) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine d_base_set_dupl + + + module subroutine d_base_set_state(n,x) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine d_base_set_state + + + module subroutine d_base_set_null(x) + class(psb_d_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine d_base_set_null + + + module subroutine d_base_set_bld(x) + class(psb_d_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine d_base_set_bld + + + module subroutine d_base_set_upd(x) + class(psb_d_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine d_base_set_upd + + + module subroutine d_base_set_asb(x) + class(psb_d_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine d_base_set_asb + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_d_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine d_base_sync(x) + class(psb_d_base_vect_type), intent(inout) :: x + + end subroutine d_base_sync + + + ! + !> Function base_set_host: + !! \memberof psb_d_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine d_base_set_host(x) + class(psb_d_base_vect_type), intent(inout) :: x + + end subroutine d_base_set_host + + + ! + !> Function base_set_dev: + !! \memberof psb_d_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine d_base_set_dev(x) + class(psb_d_base_vect_type), intent(inout) :: x + + end subroutine d_base_set_dev + + + ! + !> Function base_set_sync: + !! \memberof psb_d_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine d_base_set_sync(x) + class(psb_d_base_vect_type), intent(inout) :: x + + end subroutine d_base_set_sync + + + ! + !> Function base_is_dev: + !! \memberof psb_d_base_vect_type + !! \brief Is vector on external device . + !! + ! + module function d_base_is_dev(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function d_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_d_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + module function d_base_is_host(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function d_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_d_base_vect_type + !! \brief Is vector on sync . + !! + ! + module function d_base_is_sync(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function d_base_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine d_base_cpy(x, y) + class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine d_base_cpy + + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_d_base_vect_type + !! \brief Number of entries + !! + ! + module function d_base_get_nrows(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function d_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_d_base_vect_type + !! \brief Size in bytes + !! + ! + module function d_base_sizeof(x) result(res) + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() + + end function d_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_d_base_vect_type + !! \brief Format + !! + ! + module function d_base_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function d_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_d_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + module function d_base_get_vect(x,n) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz, i + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + if (.false.) then + res(1:isz) = x%v(1:isz) + else + !$omp parallel do private(i) + do i=1, isz + res(i) = x%v(i) + end do + end if + + end function d_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_d_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine d_base_set_scal(x,val,first,last) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val + end do +#else + x%v(first_:last_) = val +#endif + call x%set_host() + + end subroutine d_base_set_scal + + + + ! + !> Function base_set_vect + !! \memberof psb_d_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine d_base_set_vect(x,val,first,last) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i, info + + if (.not.allocated(x%v)) then + call psb_realloc(size(val),x%v,info) + end if + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val(i-first_+1) + end do +#else + x%v(first_:last_) = val(1:last_-first_+1) +#endif + call x%set_host() + + end subroutine d_base_set_vect + + + module subroutine d_base_check_addr(x) + class(psb_d_base_vect_type), intent(inout) :: x + + write(0,*) 'Check addr: base version, do nothing' + + end subroutine d_base_check_addr + + + + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_d_base_vect_type + !! \brief Get one entry from the vector + !! + ! + module function d_base_get_entry(x, index) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: res + + res = dzero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if + + end function d_base_get_entry + + module subroutine d_base_set_entry(x, index, val) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + end subroutine d_base_set_entry + + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_d_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine d_base_absval1(x) + class(psb_d_base_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: i + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1, size(x%v) + x%v(i) = abs(x%v(i)) + end do +#else + x%v = abs(x%v) +#endif + call x%set_host() + end if + + end subroutine d_base_absval1 + + + module subroutine d_base_absval2(x,y) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_) :: info + if (.not.x%is_host()) call x%sync() + if (allocated(x%v)) then + call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) + call y%absval() + end if + + end subroutine d_base_absval2 + + + ! + ! Dot products + ! + ! + !> Function base_dot_v + !! \memberof psb_d_base_vect_type + !! \brief Dot product by another base_vector + !! \param n Number of entries to be considered + !! \param y The other (base_vect) to be multiplied by + !! + module function d_base_dot_v(n,x,y) result(res) + class(psb_d_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + real(psb_dpk_), external :: ddot + + res = dzero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_d_base_vect. + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_d_base_vect_type) + res = ddot(n,x%v,1,y%v,1) + class default + res = y%dot(n,x%v) + end select + + end function d_base_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_dot_a + !! \memberof psb_d_base_vect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function d_base_dot_a(n,x,y) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + real(psb_dpk_), external :: ddot + + res = ddot(n,y,1,x%v,1) + + end function d_base_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_axpby_v + !! \memberof psb_d_base_vect_type + !! \brief AXPBY by a (base_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine d_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call y%axpby(m,alpha,x%v,beta,info) + + end subroutine d_base_axpby_v + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_d_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + module subroutine d_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine d_base_axpby_v2 + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_axpby_a + !! \memberof psb_d_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine d_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (y%is_dev()) call y%sync() + call psb_geaxpby(m,alpha,x,beta,y%v,info) + call y%set_host() + + end subroutine d_base_axpby_a + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_d_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + module subroutine d_base_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_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine d_base_axpby_a2 + + + ! + ! UPD_XYZ is invoked via Z, hence the structure below. + ! + ! + !> Function base_upd_xyz + !! \memberof psb_d_base_vect_type + !! \brief UPD_XYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param beta scalar beta + !! \param gamma scalar gamma + !! \param delta scalar delta + !! \param x The class(base_vect) to be added + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be added + !! \param info return code + !! + module subroutine d_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(alpha/=dzero)) call x%sync() + if (y%is_dev().and.(beta/=dzero)) call y%sync() + if (z%is_dev().and.(delta/=dzero)) call z%sync() + call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) + call y%set_host() + call z%set_host() + + end subroutine d_base_upd_xyz + + + module subroutine d_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + class(psb_d_base_vect_type), intent(inout) :: w + real(psb_dpk_), intent (in) :: a,b,c,d,e,f + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(a/=dzero)) call x%sync() + if (y%is_dev().and.(b/=dzero)) call y%sync() + if (z%is_dev().and.(d/=dzero)) call z%sync() + if (w%is_dev().and.(f/=dzero)) call w%sync() + call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) + call y%set_host() + call z%set_host() + call w%set_host() + + end subroutine d_base_xyzw + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:) = X(:)*Y(:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlt_a + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry multiply by a base_vect array y=x*y + !! \param x The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlt_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine d_base_mlt_v + + + ! + !> Function base_mlt_a + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry multiply by a normal array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlt_a(x, y, info) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)*x(i) + end do + call y%set_host() + + end subroutine d_base_mlt_a + + + + ! + !> Function base_mlt_a_2 + !! \memberof psb_d_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine d_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(z%v), size(x), size(y)) + if (alpha == dzero) then + if (beta == done) then + return + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + end do + end if + else + if (alpha == done) then + if (beta == dzero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = y(i)*x(i) + end do + else if (beta == done) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) + y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + y(i)*x(i) + end do + end if + else if (alpha == -done) then + if (beta == dzero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = -y(i)*x(i) + end do + else if (beta == done) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) - y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) - y(i)*x(i) + end do + end if + else + if (beta == dzero) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = alpha*y(i)*x(i) + end do + else if (beta == done) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = z%v(i) + alpha*y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(alpha, beta) + do i=1, n + z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) + end do + end if + end if + end if + call z%set_host() + + end subroutine d_base_mlt_a_2 + + + ! + !> Function base_mlt_v_2 + !! \memberof psb_d_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_vect) to be multiplied b + !! \param y The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_dpk_), intent(in) :: alpha,beta + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (y%is_dev()) call y%sync() + if (x%is_dev()) call x%sync() + if (.not.psb_d_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + end if + end subroutine d_base_mlt_v_2 + + + module subroutine d_base_mlt_av(alpha,x,y,beta,z,info) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call z%mlt(alpha,x,y%v,beta,info) + + end subroutine d_base_mlt_av + + + module subroutine d_base_mlt_va(alpha,x,y,beta,z,info) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call z%mlt(alpha,y,x,beta,info) + + end subroutine d_base_mlt_va + + ! + !> Function base_div_v + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine d_base_div_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%div(x%v,info) + + end subroutine d_base_div_v + + + module subroutine d_base_div_a(x, y, info) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)/x(i) + end do + call y%set_host() + + end subroutine d_base_div_a + + ! + !> Function base_div_v2 + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine d_base_div_v2(x, y, z, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call z%div(x%v,y%v,info) + call z%set_host() + end subroutine d_base_div_v2 + + ! + !> Function base_div_v_check + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine d_base_div_v_check(x, y, info, flag) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call x%div(x%v,y%v,info,flag) + + end subroutine d_base_div_v_check + + ! + !> Function base_div_v2_check + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine d_base_div_v2_check(x, y, z, info, flag) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + end subroutine d_base_div_v2_check + + ! + !> Function base_div_a2 + !! \memberof psb_d_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + module subroutine d_base_div_a2(x, y, z, info) + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + !$omp parallel do private(i) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine d_base_div_a2 + + ! + !> Function base_div_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + module subroutine d_base_div_a2_check(x, y, z, info, flag) + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call d_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + ! $omp parallel do private(i) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine d_base_div_a2_check + + ! + !> Function base_inv_v + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + module subroutine d_base_inv_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine d_base_inv_v + + ! + !> Function base_inv_v_check + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + module subroutine d_base_inv_v_check(x, y, info, flag) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + end subroutine d_base_inv_v_check + + ! + !> Function base_inv_a2 + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + module subroutine d_base_inv_a2(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + y%v(i) = 1_psb_dpk_/x(i) + end do + + end subroutine d_base_inv_a2 + + ! + !> Function base_inv_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + module subroutine d_base_inv_a2_check(x, y, info, flag) + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call d_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_dpk_/x(i) + else + info = 1 + y%v(i) = 0_psb_dpk_ + end if + end do + end if + + + end subroutine d_base_inv_a2_check + + + ! + !> Function base_inv_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine d_base_acmp_a2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + !$omp parallel do private(i) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_dpk_ + else + z%v(i) = 0_psb_dpk_ + end if + end do + info = 0 + + end subroutine d_base_acmp_a2 + + ! + !> Function base_cmp_v2 + !! \memberof psb_d_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine d_base_acmp_v2(x,c,z,info) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine d_base_acmp_v2 + + + ! + ! Simple scaling + ! + !> Function base_scal + !! \memberof psb_d_base_vect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! + module subroutine d_base_scal(alpha, x) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent (in) :: alpha + integer(psb_ipk_) :: i + + if (allocated(x%v)) then +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1,size(x%v) + x%v(i) = alpha*x%v(i) + end do +#else + x%v = alpha*x%v +#endif + end if + call x%set_host() + end subroutine d_base_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_nrm2 + !! \memberof psb_d_base_vect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function d_base_nrm2(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + real(psb_dpk_), external :: dnrm2 + + if (x%is_dev()) call x%sync() + res = dnrm2(n,x%v,1) + + end function d_base_nrm2 + + ! + !> Function base_amax + !! \memberof psb_d_base_vect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function d_base_amax(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res = dzero + !$omp parallel do private(i) reduction(max: res) + do i=1, n + res = max(res,abs(x%v(i))) + end do +#else + res = maxval(abs(x%v(1:n))) +#endif + end function d_base_amax + + ! + !> Function base_min + !! \memberof psb_d_base_vect_type + !! \brief min x(1:n) + !! \param n how many entries to consider + module function d_base_min(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res = HUGE(done) + !$omp parallel do private(i) reduction(min: res) + do i=1, n + res = min(res,abs(x%v(i))) + end do +#else + ! + ! From M&R&C: if the array is of size zero, MINVAL + ! returns the largest positive value + ! + res = minval(x%v(1:n)) +#endif + end function d_base_min + + ! + !> Function base_minquotient_v + !! \memberof psb_d_base_vect_type + !! \brief Minimum entry of the vector entry-by-entry divide x/y + !! \param x The numerator vector + !! \param y The denumerator vector + !! \param info return code + !! + module function d_base_minquotient_v(x, y, info) result(z) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + + z = x%minquotient(y%v,info) + + end function d_base_minquotient_v + + ! + !> Function base_minquotient_a2 + !! \memberof psb_d_base_vect_type + !! \brief Minimum entry of the array entry-by-entry divide x/y + !! \param x The numerator array + !! \param y The denumerator array + !! \param info return code + !! + module function d_base_minquotient_a2(x, y, info) result(z) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + real(psb_dpk_) :: temp + + info = 0 + + z = huge(z) + n = min(size(y), size(x%v)) + !$omp parallel do private(i,temp) reduction(min: z) + do i=1, n + if ( y(i) /= dzero ) then + temp = x%v(i)/y(i) + z = min(z,temp) + end if + end do + + end function d_base_minquotient_a2 + + + ! + !> Function base_asum + !! \memberof psb_d_base_vect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function d_base_asum(n,x) result(res) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res=dzero + !$omp parallel do private(i) reduction(+: res) + do i= 1, size(x%v) + res = res + abs(x%v(i)) + end do +#else + res = sum(abs(x%v(1:n))) +#endif + end function d_base_asum + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_d_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine d_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine d_base_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_d_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine d_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: y(:) + class(psb_d_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine d_base_gthzv_x + + + ! + ! New comm internals impl. + ! + module subroutine d_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_d_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine d_base_gthzbuf + + ! + !> Function base_device_wait: + !! \memberof psb_d_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine d_base_device_wait() + + end subroutine d_base_device_wait + + + module function d_base_use_buffer() result(res) + logical :: res + + res = .true. + end function d_base_use_buffer + + module subroutine d_base_new_buffer(n,x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine d_base_new_buffer + + + module subroutine d_base_new_comid(n,x,info) + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine d_base_new_comid + + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_d_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine d_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine d_base_gthzv + + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_d_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine d_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine d_base_sctb + + + module subroutine d_base_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_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine d_base_sctb_x + + + module subroutine d_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta + class(psb_d_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine d_base_sctb_buf + + + ! + !> Function base_mask_a + !! \memberof psb_d_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The array to be compared + !! \param c The array containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + module subroutine d_base_mask_a(c,x,m,t,info) + real(psb_dpk_), intent(inout) :: c(:) + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + integer(psb_ipk_) :: i, n + + if (m%is_dev()) call m%sync() + t = .true. + + n = size(x) + do i = 1, n, 1 + if (c(i).eq.2_psb_dpk_) then + if ( x(i) > dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + elseif (c(i).eq.1_psb_dpk_) then + if ( x(i) >= dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + elseif (c(i).eq.-1_psb_dpk_) then + if ( x(i) <= dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + elseif (c(i).eq.-2_psb_dpk_) then + if ( x(i) < dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + else + m%v(i) = 0_psb_dpk_ + end if + end do + info = 0 + + end subroutine d_base_mask_a + + ! + !> Function base_mask_v + !! \memberof psb_d_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The vector to be compared + !! \param c The vector containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + module subroutine d_base_mask_v(c,x,m,t,info) + class(psb_d_base_vect_type), intent(inout) :: c + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + + info = 0 + if (x%is_dev()) call x%sync() + if (c%is_dev()) call c%sync() + + call m%mask(x%v,c%v,t,info) + end subroutine d_base_mask_v + + + + ! + !> Function _base_addconst_a2 + !! \memberof psb_d_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine d_base_addconst_a2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() +#if defined(PSB_OPENMP) + n = size(x) + !$omp parallel do private(i) + do i = 1, n + z%v(i) = x(i) + b + end do +#else + z%v = x + b +#endif + info = 0 + + end subroutine d_base_addconst_a2 + + ! + !> Function _base_addconst_v2 + !! \memberof psb_d_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine d_base_addconst_v2(x,b,z,info) + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: b + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine d_base_addconst_v2 + +end submodule psb_d_base_vect_impl + + +submodule (psb_d_base_multivect_mod) psb_d_base_multivect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_d_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine d_base_mlv_bld_x(x,this) + real(psb_dpk_), intent(in) :: this(:,:) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine d_base_mlv_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_d_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine d_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info,scratch=scratch) + + end subroutine d_base_mlv_bld_n + + + !> Function base_mlv_all: + !! \memberof psb_d_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine d_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine d_base_mlv_all + + + !> Function base_mlv_mold: + !! \memberof psb_d_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine d_base_mlv_mold(x, y, info) + class(psb_d_base_multivect_type), intent(in) :: x + class(psb_d_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_d_base_multivect_type :: y, stat=info) + + end subroutine d_base_mlv_mold + + + module subroutine d_base_mlv_reinit(x, info) + class(psb_d_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = dzero + call x%set_host() + call x%set_upd() + end if + + end subroutine d_base_mlv_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_d_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine d_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine d_base_mlv_ins + + + ! + !> Function base_mlv_zero + !! \memberof psb_d_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine d_base_mlv_zero(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=dzero + call x%set_host() + + end subroutine d_base_mlv_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_d_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine d_base_mlv_asb(m,n, x, info, scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_dpk_), allocatable :: vv(:,:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(m,n,vv,info) + vv(:,:) = dzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i),:) = x%v(i,:) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (any(vv(x%iv(i),:).ne.dzero)) then + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') + return + else + vv(x%iv(i),:) = x%v(i,:) + end if + end do + case default + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_d_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine d_base_mlv_free(x, info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine d_base_mlv_free + + + module function d_base_mlv_get_ncfs(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function d_base_mlv_get_ncfs + + module function d_base_mlv_get_dupl(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function d_base_mlv_get_dupl + + module function d_base_mlv_get_state(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function d_base_mlv_get_state + + module function d_base_mlv_is_null(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function d_base_mlv_is_null + + module function d_base_mlv_is_bld(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function d_base_mlv_is_bld + + module function d_base_mlv_is_upd(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function d_base_mlv_is_upd + + module function d_base_mlv_is_asb(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function d_base_mlv_is_asb + + module subroutine d_base_mlv_set_ncfs(n,x) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine d_base_mlv_set_ncfs + + + module subroutine d_base_mlv_set_dupl(n,x) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine d_base_mlv_set_dupl + + + module subroutine d_base_mlv_set_state(n,x) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine d_base_mlv_set_state + + + module subroutine d_base_mlv_set_null(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine d_base_mlv_set_null + + + module subroutine d_base_mlv_set_bld(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine d_base_mlv_set_bld + + + module subroutine d_base_mlv_set_upd(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine d_base_mlv_set_upd + + + module subroutine d_base_mlv_set_asb(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine d_base_mlv_set_asb + + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_d_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine d_base_mlv_sync(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + end subroutine d_base_mlv_sync + + + ! + !> Function base_mlv_set_host: + !! \memberof psb_d_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine d_base_mlv_set_host(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + end subroutine d_base_mlv_set_host + + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_d_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine d_base_mlv_set_dev(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + end subroutine d_base_mlv_set_dev + + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_d_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine d_base_mlv_set_sync(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + end subroutine d_base_mlv_set_sync + + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_d_base_multivect_type + !! \brief Is vector on external device . + !! + ! + module function d_base_mlv_is_dev(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function d_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_d_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + module function d_base_mlv_is_host(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function d_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_d_base_multivect_type + !! \brief Is vector on sync . + !! + ! + module function d_base_mlv_is_sync(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function d_base_mlv_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine d_base_mlv_cpy(x, y) + class(psb_d_base_multivect_type), intent(in) :: x + class(psb_d_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine d_base_mlv_cpy + + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_d_base_multivect_type + !! \brief Number of entries + !! + ! + module function d_base_mlv_get_nrows(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function d_base_mlv_get_nrows + + module function d_base_mlv_get_ncols(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function d_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_d_base_multivect_type + !! \brief Size in bytesa + !! + ! + module function d_base_mlv_sizeof(x) result(res) + class(psb_d_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() * x%get_ncols() + + end function d_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_d_base_multivect_type + !! \brief Format + !! + ! + module function d_base_mlv_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function d_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_d_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + module function d_base_mlv_get_vect(x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function d_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_d_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine d_base_mlv_set_scal(x,val) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine d_base_mlv_set_scal + + + ! + !> Function base_mlv_set_vect + !! \memberof psb_d_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine d_base_mlv_set_vect(x,val) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine d_base_mlv_set_vect + + + ! + ! Dot products + ! + ! + !> Function base_mlv_dot_v + !! \memberof psb_d_base_multivect_type + !! \brief Dot product by another base_mlv_vector + !! \param n Number of entries to be considered + !! \param y The other (base_mlv_vect) to be multiplied by + !! + module function d_base_mlv_dot_v(n,x,y) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + real(psb_dpk_), external :: ddot + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + res = dzero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_d_base_mlv_vect (or its class does not care). + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_d_base_multivect_type) + if (y%is_dev()) call y%sync() + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = ddot(n,x%v(:,j),1,y%v(:,j),1) + end do + class default + res = y%dot(n,x%v) + end select + + end function d_base_mlv_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_mlv_dot_a + !! \memberof psb_d_base_multivect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function d_base_mlv_dot_a(n,x,y) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + real(psb_dpk_), external :: ddot + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = ddot(n,x%v(:,j),1,y(:,j),1) + end do + + end function d_base_mlv_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_mlv_axpby_v + !! \memberof psb_d_base_multivect_type + !! \brief AXPBY by a (base_mlv_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_mlv_vect) to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine d_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + + if (present(n)) then + nc = n + else + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + end if + select type(xx => x) + type is (psb_d_base_multivect_type) + call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) + class default + call y%axpby(m,alpha,x%v,beta,info,n=n) + end select + + end subroutine d_base_mlv_axpby_v + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_mlv_axpby_a + !! \memberof psb_d_base_multivect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine d_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:,:) + class(psb_d_base_multivect_type), intent(inout) :: y + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + if (present(n)) then + nc = n + else + nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) + end if + + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) + + end subroutine d_base_mlv_axpby_a + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlv_mlt_mv + !! \memberof psb_d_base_multivect_type + !! \brief Multivector entry-by-entry multiply by a base_mlv_multivect y=x*y + !! \param x The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlv_mlt_mv(x, y, info) + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine d_base_mlv_mlt_mv + + + module subroutine d_base_mlv_mlt_mv_v(x, y, info) + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine d_base_mlv_mlt_mv_v + + + ! + !> Function base_mlv_mlt_ar1 + !! \memberof psb_d_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 1 array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlv_mlt_ar1(x, y, info) + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + n = min(psb_size(y%v,1_psb_ipk_), size(x)) + do i=1, n + y%v(i,:) = y%v(i,:)*x(i) + end do + + end subroutine d_base_mlv_mlt_ar1 + + + ! + !> Function base_mlv_mlt_ar2 + !! \memberof psb_d_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 2 array y=x*y + !! \param x(:,:) The array to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlv_mlt_ar2(x, y, info) + real(psb_dpk_), intent(in) :: x(:,:) + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr,nc + + info = 0 + nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) + nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) + y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) + + end subroutine d_base_mlv_mlt_ar2 + + + + ! + !> Function base_mlv_mlt_a_2 + !! \memberof psb_d_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr, nc + + info = 0 + nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == dzero) then + if (beta == done) then + return + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + end if + else + if (alpha == done) then + if (beta == dzero) then + z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == done) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else if (alpha == -done) then + if (beta == dzero) then + z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == done) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else + if (beta == dzero) then + z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == done) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + end if + end if + end if + end subroutine d_base_mlv_mlt_a_2 + + + ! + !> Function base_mlv_mlt_v_2 + !! \memberof psb_d_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_mlv_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_mlv_vect) to be multiplied b + !! \param y The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine d_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_dpk_), intent(in) :: alpha,beta + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + class(psb_d_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + if (z%is_dev()) call z%sync() + if (.not.psb_d_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + end if + end subroutine d_base_mlv_mlt_v_2 + +!!$ +!!$ subroutine d_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ real(psb_dpk_), intent(in) :: alpha,beta +!!$ real(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_d_base_multivect_type), intent(inout) :: y +!!$ class(psb_d_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine d_base_mlv_mlt_av + +!!$ +!!$ subroutine d_base_mlv_mlt_va(alpha,x,y,beta,z,info) +!!$ real(psb_dpk_), intent(in) :: alpha,beta +!!$ real(psb_dpk_), intent(in) :: y(:) +!!$ class(psb_d_base_multivect_type), intent(inout) :: x +!!$ class(psb_d_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,y,x,beta,info) +!!$ +!!$ end subroutine d_base_mlv_mlt_va + +!!$ +!!$ + ! + ! Simple scaling + ! + !> Function base_mlv_scal + !! \memberof psb_d_base_multivect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! +module subroutine d_base_mlv_scal(alpha, x) + class(psb_d_base_multivect_type), intent(inout) :: x + real(psb_dpk_), intent (in) :: alpha + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) x%v = alpha*x%v + + end subroutine d_base_mlv_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_mlv_nrm2 + !! \memberof psb_d_base_multivect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function d_base_mlv_nrm2(n,x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + real(psb_dpk_), external :: dnrm2 + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = dnrm2(n,x%v(:,j),1) + end do + + end function d_base_mlv_nrm2 + + + ! + !> Function base_mlv_amax + !! \memberof psb_d_base_multivect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function d_base_mlv_amax(n,x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = maxval(abs(x%v(1:n,j))) + end do + + end function d_base_mlv_amax + + + ! + !> Function base_mlv_asum + !! \memberof psb_d_base_multivect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function d_base_mlv_asum(n,x) result(res) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = sum(abs(x%v(1:n,j))) + end do + + end function d_base_mlv_asum + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_d_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine d_base_mlv_absval1(x) + class(psb_d_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v = abs(x%v) + call x%set_host() + end if + + end subroutine d_base_mlv_absval1 + + + module subroutine d_base_mlv_absval2(x,y) + class(psb_d_base_multivect_type), intent(inout) :: x + class(psb_d_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) then + call y%axpby(min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) + call y%absval() + end if + + end subroutine d_base_mlv_absval2 + + + + module function d_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function d_base_mlv_use_buffer + + + module subroutine d_base_mlv_new_buffer(n,x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine d_base_mlv_new_buffer + + + module subroutine d_base_mlv_new_comid(n,x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine d_base_mlv_new_comid + + + + module subroutine d_base_mlv_maybe_free_buffer(x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine d_base_mlv_maybe_free_buffer + + + module subroutine d_base_mlv_free_buffer(x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine d_base_mlv_free_buffer + + + module subroutine d_base_mlv_free_comid(x,info) + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine d_base_mlv_free_comid + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_d_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine d_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine d_base_mlv_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_d_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine d_base_mlv_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_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine d_base_mlv_gthzv_x + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_d_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine d_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine d_base_mlv_gthzv + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_d_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine d_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: y(:,:) + class(psb_d_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine d_base_mlv_gthzm + + + ! + ! New comm internals impl. + ! + module subroutine d_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_d_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine d_base_mlv_gthzbuf + + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_d_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine d_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine d_base_mlv_sctb + + + module subroutine d_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_dpk_) :: beta, x(:,:) + class(psb_d_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine d_base_mlv_sctbr2 + + + module subroutine d_base_mlv_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_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine d_base_mlv_sctb_x + + + module subroutine d_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta + class(psb_d_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine d_base_mlv_sctb_buf + + + ! + !> Function base_device_wait: + !! \memberof psb_d_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine d_base_mlv_device_wait() + + end subroutine d_base_mlv_device_wait + +end submodule psb_d_base_multivect_impl 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 000000000..c3eb5cde7 --- /dev/null +++ b/base/serial/impl/psb_d_vect_impl.F90 @@ -0,0 +1,1690 @@ +! +! 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 psb_base_mod + use psi_serial_mod + implicit none + +contains + + module function d_vect_get_dupl(x) result(res) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + + 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) + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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%div(x%v,info) + + end subroutine d_vect_div_v + + 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 + 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) + 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%div(x%v,info,flag) + + end subroutine d_vect_div_v_check + + 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 + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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(done) + end if + + end function d_vect_min + + 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 + + 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) + 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) + 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) + 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) + 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) + 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 psb_base_mod + use psi_serial_mod + +contains + + module function d_mvect_get_dupl(x) result(res) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + 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) + + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) +!!$ 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 +!!$ +!!$ function d_mvect_dot_a(n,x,y) result(res) +!!$ 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) +!!$ 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 +!!$ +!!$ subroutine d_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine d_mvect_mlt_v(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 +!!$ 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 +!!$ +!!$ subroutine d_mvect_mlt_a(x, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine d_mvect_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_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 +!!$ +!!$ subroutine d_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ 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 +!!$ +!!$ subroutine d_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine d_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine d_mvect_scal(alpha, x) +!!$ 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 +!!$ +!!$ +!!$ function d_mvect_nrm2(n,x) result(res) +!!$ 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 +!!$ +!!$ function d_mvect_amax(n,x) result(res) +!!$ 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 +!!$ +!!$ function d_mvect_asum(n,x) result(res) +!!$ 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_base_vect_impl.F90 b/base/serial/impl/psb_i_base_vect_impl.F90 new file mode 100644 index 000000000..3f3d39605 --- /dev/null +++ b/base/serial/impl/psb_i_base_vect_impl.F90 @@ -0,0 +1,2152 @@ +! +! 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_base_vect_mod +! +! This module contains the definition of the psb_i_base_vect type which +! is a container for dense vectors. +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +submodule (psb_i_base_vect_mod) psb_i_base_vect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_i_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine i_base_bld_x(x,this,scratch) + integer(psb_ipk_), intent(in) :: this(:) + class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + integer(psb_ipk_) :: i + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if +#if defined (PSB_OPENMP) + !$omp parallel do private(i) + do i = 1, size(this) + x%v(i) = this(i) + end do +#else + x%v(:) = this(:) +#endif + end subroutine i_base_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_i_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine i_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine i_base_bld_mn + + + !> Function bld_en: + !! \memberof psb_i_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine i_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine i_base_bld_en + + + !> Function base_all: + !! \memberof psb_i_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine i_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_i_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine i_base_all + + + !> Function base_mold: + !! \memberof psb_i_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine i_base_mold(x, y, info) + class(psb_i_base_vect_type), intent(in) :: x + class(psb_i_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_i_base_vect_type :: y, stat=info) + + end subroutine i_base_mold + + + module subroutine i_base_reinit(x, info,clear) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + logical :: clear_ + + info = 0 + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + if (clear_) x%v(:) = izero + call x%set_host() + call x%set_upd() + end if + + end subroutine i_base_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_i_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine i_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine i_base_ins_a + + + module subroutine i_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_i_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,maxr,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine i_base_ins_v + + + + ! + !> Function base_zero + !! \memberof psb_i_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine i_base_zero(x) + class(psb_i_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) then + !$omp workshare + x%v(:)=izero + !$omp end workshare + end if + call x%set_host() + end subroutine i_base_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_i_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine i_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_ipk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = izero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne. izero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine i_base_asb_m + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_i_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine i_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_ipk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = izero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne. izero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine i_base_asb_e + + + ! + !> Function base_free: + !! \memberof psb_i_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine i_base_free(x, info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) + if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + call x%set_null() + end subroutine i_base_free + + + ! + !> Function base_free_buffer: + !! \memberof psb_i_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + module subroutine i_base_free_buffer(x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine i_base_free_buffer + + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_i_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + module subroutine i_base_maybe_free_buffer(x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine i_base_maybe_free_buffer + + + ! + !> Function base_free_comid: + !! \memberof psb_i_base_vect_type + !! \brief Free aux MPI communication id buffer + !! + !! \param info return code + !! + ! + module subroutine i_base_free_comid(x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine i_base_free_comid + + + module function i_base_get_ncfs(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function i_base_get_ncfs + + module function i_base_get_dupl(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function i_base_get_dupl + + module function i_base_get_state(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function i_base_get_state + + module function i_base_is_null(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function i_base_is_null + + module function i_base_is_bld(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function i_base_is_bld + + module function i_base_is_upd(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function i_base_is_upd + + module function i_base_is_asb(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function i_base_is_asb + + module subroutine i_base_set_ncfs(n,x) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine i_base_set_ncfs + + + module subroutine i_base_set_dupl(n,x) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine i_base_set_dupl + + + module subroutine i_base_set_state(n,x) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine i_base_set_state + + + module subroutine i_base_set_null(x) + class(psb_i_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine i_base_set_null + + + module subroutine i_base_set_bld(x) + class(psb_i_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine i_base_set_bld + + + module subroutine i_base_set_upd(x) + class(psb_i_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine i_base_set_upd + + + module subroutine i_base_set_asb(x) + class(psb_i_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine i_base_set_asb + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_i_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine i_base_sync(x) + class(psb_i_base_vect_type), intent(inout) :: x + + end subroutine i_base_sync + + + ! + !> Function base_set_host: + !! \memberof psb_i_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine i_base_set_host(x) + class(psb_i_base_vect_type), intent(inout) :: x + + end subroutine i_base_set_host + + + ! + !> Function base_set_dev: + !! \memberof psb_i_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine i_base_set_dev(x) + class(psb_i_base_vect_type), intent(inout) :: x + + end subroutine i_base_set_dev + + + ! + !> Function base_set_sync: + !! \memberof psb_i_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine i_base_set_sync(x) + class(psb_i_base_vect_type), intent(inout) :: x + + end subroutine i_base_set_sync + + + ! + !> Function base_is_dev: + !! \memberof psb_i_base_vect_type + !! \brief Is vector on external device . + !! + ! + module function i_base_is_dev(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function i_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_i_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + module function i_base_is_host(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function i_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_i_base_vect_type + !! \brief Is vector on sync . + !! + ! + module function i_base_is_sync(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function i_base_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine i_base_cpy(x, y) + class(psb_i_base_vect_type), intent(in) :: x + class(psb_i_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine i_base_cpy + + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_i_base_vect_type + !! \brief Number of entries + !! + ! + module function i_base_get_nrows(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function i_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_i_base_vect_type + !! \brief Size in bytes + !! + ! + module function i_base_sizeof(x) result(res) + class(psb_i_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() + + end function i_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_i_base_vect_type + !! \brief Format + !! + ! + module function i_base_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function i_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_i_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + module function i_base_get_vect(x,n) result(res) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz, i + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + if (.false.) then + res(1:isz) = x%v(1:isz) + else + !$omp parallel do private(i) + do i=1, isz + res(i) = x%v(i) + end do + end if + + end function i_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_i_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine i_base_set_scal(x,val,first,last) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val + end do +#else + x%v(first_:last_) = val +#endif + call x%set_host() + + end subroutine i_base_set_scal + + + + ! + !> Function base_set_vect + !! \memberof psb_i_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine i_base_set_vect(x,val,first,last) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i, info + + if (.not.allocated(x%v)) then + call psb_realloc(size(val),x%v,info) + end if + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val(i-first_+1) + end do +#else + x%v(first_:last_) = val(1:last_-first_+1) +#endif + call x%set_host() + + end subroutine i_base_set_vect + + + module subroutine i_base_check_addr(x) + class(psb_i_base_vect_type), intent(inout) :: x + + write(0,*) 'Check addr: base version, do nothing' + + end subroutine i_base_check_addr + + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_i_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine i_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine i_base_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_i_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine i_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: y(:) + class(psb_i_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine i_base_gthzv_x + + + ! + ! New comm internals impl. + ! + module subroutine i_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_i_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine i_base_gthzbuf + + ! + !> Function base_device_wait: + !! \memberof psb_i_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine i_base_device_wait() + + end subroutine i_base_device_wait + + + module function i_base_use_buffer() result(res) + logical :: res + + res = .true. + end function i_base_use_buffer + + module subroutine i_base_new_buffer(n,x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine i_base_new_buffer + + + module subroutine i_base_new_comid(n,x,info) + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine i_base_new_comid + + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_i_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine i_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine i_base_gthzv + + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_i_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine i_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine i_base_sctb + + + module subroutine i_base_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_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine i_base_sctb_x + + + module subroutine i_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta + class(psb_i_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine i_base_sctb_buf + + + +end submodule psb_i_base_vect_impl + + +submodule (psb_i_base_multivect_mod) psb_i_base_multivect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_i_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine i_base_mlv_bld_x(x,this) + integer(psb_ipk_), intent(in) :: this(:,:) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine i_base_mlv_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_i_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine i_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info,scratch=scratch) + + end subroutine i_base_mlv_bld_n + + + !> Function base_mlv_all: + !! \memberof psb_i_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine i_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine i_base_mlv_all + + + !> Function base_mlv_mold: + !! \memberof psb_i_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine i_base_mlv_mold(x, y, info) + class(psb_i_base_multivect_type), intent(in) :: x + class(psb_i_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_i_base_multivect_type :: y, stat=info) + + end subroutine i_base_mlv_mold + + + module subroutine i_base_mlv_reinit(x, info) + class(psb_i_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = izero + call x%set_host() + call x%set_upd() + end if + + end subroutine i_base_mlv_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_i_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine i_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_ipk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine i_base_mlv_ins + + + ! + !> Function base_mlv_zero + !! \memberof psb_i_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine i_base_mlv_zero(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=izero + call x%set_host() + + end subroutine i_base_mlv_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_i_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine i_base_mlv_asb(m,n, x, info, scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_ipk_), allocatable :: vv(:,:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(m,n,vv,info) + vv(:,:) = izero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i),:) = x%v(i,:) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (any(vv(x%iv(i),:).ne.izero)) then + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') + return + else + vv(x%iv(i),:) = x%v(i,:) + end if + end do + case default + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_i_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine i_base_mlv_free(x, info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine i_base_mlv_free + + + module function i_base_mlv_get_ncfs(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function i_base_mlv_get_ncfs + + module function i_base_mlv_get_dupl(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function i_base_mlv_get_dupl + + module function i_base_mlv_get_state(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function i_base_mlv_get_state + + module function i_base_mlv_is_null(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function i_base_mlv_is_null + + module function i_base_mlv_is_bld(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function i_base_mlv_is_bld + + module function i_base_mlv_is_upd(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function i_base_mlv_is_upd + + module function i_base_mlv_is_asb(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function i_base_mlv_is_asb + + module subroutine i_base_mlv_set_ncfs(n,x) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine i_base_mlv_set_ncfs + + + module subroutine i_base_mlv_set_dupl(n,x) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine i_base_mlv_set_dupl + + + module subroutine i_base_mlv_set_state(n,x) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine i_base_mlv_set_state + + + module subroutine i_base_mlv_set_null(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine i_base_mlv_set_null + + + module subroutine i_base_mlv_set_bld(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine i_base_mlv_set_bld + + + module subroutine i_base_mlv_set_upd(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine i_base_mlv_set_upd + + + module subroutine i_base_mlv_set_asb(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine i_base_mlv_set_asb + + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_i_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine i_base_mlv_sync(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + end subroutine i_base_mlv_sync + + + ! + !> Function base_mlv_set_host: + !! \memberof psb_i_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine i_base_mlv_set_host(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + end subroutine i_base_mlv_set_host + + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_i_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine i_base_mlv_set_dev(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + end subroutine i_base_mlv_set_dev + + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_i_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine i_base_mlv_set_sync(x) + class(psb_i_base_multivect_type), intent(inout) :: x + + end subroutine i_base_mlv_set_sync + + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_i_base_multivect_type + !! \brief Is vector on external device . + !! + ! + module function i_base_mlv_is_dev(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function i_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_i_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + module function i_base_mlv_is_host(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function i_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_i_base_multivect_type + !! \brief Is vector on sync . + !! + ! + module function i_base_mlv_is_sync(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function i_base_mlv_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine i_base_mlv_cpy(x, y) + class(psb_i_base_multivect_type), intent(in) :: x + class(psb_i_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine i_base_mlv_cpy + + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_i_base_multivect_type + !! \brief Number of entries + !! + ! + module function i_base_mlv_get_nrows(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function i_base_mlv_get_nrows + + module function i_base_mlv_get_ncols(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function i_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_i_base_multivect_type + !! \brief Size in bytesa + !! + ! + module function i_base_mlv_sizeof(x) result(res) + class(psb_i_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() + + end function i_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_i_base_multivect_type + !! \brief Format + !! + ! + module function i_base_mlv_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function i_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_i_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + module function i_base_mlv_get_vect(x) result(res) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function i_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_i_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine i_base_mlv_set_scal(x,val) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine i_base_mlv_set_scal + + + ! + !> Function base_mlv_set_vect + !! \memberof psb_i_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine i_base_mlv_set_vect(x,val) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine i_base_mlv_set_vect + + + + module function i_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function i_base_mlv_use_buffer + + + module subroutine i_base_mlv_new_buffer(n,x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine i_base_mlv_new_buffer + + + module subroutine i_base_mlv_new_comid(n,x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine i_base_mlv_new_comid + + + + module subroutine i_base_mlv_maybe_free_buffer(x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine i_base_mlv_maybe_free_buffer + + + module subroutine i_base_mlv_free_buffer(x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine i_base_mlv_free_buffer + + + module subroutine i_base_mlv_free_comid(x,info) + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine i_base_mlv_free_comid + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine i_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine i_base_mlv_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine i_base_mlv_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_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine i_base_mlv_gthzv_x + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine i_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine i_base_mlv_gthzv + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine i_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: y(:,:) + class(psb_i_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine i_base_mlv_gthzm + + + ! + ! New comm internals impl. + ! + module subroutine i_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine i_base_mlv_gthzbuf + + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_i_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine i_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine i_base_mlv_sctb + + + module subroutine i_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_ipk_) :: beta, x(:,:) + class(psb_i_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine i_base_mlv_sctbr2 + + + module subroutine i_base_mlv_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_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine i_base_mlv_sctb_x + + + module subroutine i_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine i_base_mlv_sctb_buf + + + ! + !> Function base_device_wait: + !! \memberof psb_i_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine i_base_mlv_device_wait() + + end subroutine i_base_mlv_device_wait + +end submodule psb_i_base_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 000000000..4173613b1 --- /dev/null +++ b/base/serial/impl/psb_i_vect_impl.F90 @@ -0,0 +1,902 @@ +! +! 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 psb_base_mod + use psi_serial_mod + implicit none + +contains + + module function i_vect_get_dupl(x) result(res) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + + 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) + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 psb_base_mod + use psi_serial_mod + +contains + + module function i_mvect_get_dupl(x) result(res) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + 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) + + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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_base_vect_impl.F90 b/base/serial/impl/psb_l_base_vect_impl.F90 new file mode 100644 index 000000000..eed17a607 --- /dev/null +++ b/base/serial/impl/psb_l_base_vect_impl.F90 @@ -0,0 +1,2152 @@ +! +! 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_base_vect_mod +! +! This module contains the definition of the psb_l_base_vect type which +! is a container for dense vectors. +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +submodule (psb_l_base_vect_mod) psb_l_base_vect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_l_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine l_base_bld_x(x,this,scratch) + integer(psb_lpk_), intent(in) :: this(:) + class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + integer(psb_ipk_) :: i + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if +#if defined (PSB_OPENMP) + !$omp parallel do private(i) + do i = 1, size(this) + x%v(i) = this(i) + end do +#else + x%v(:) = this(:) +#endif + end subroutine l_base_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_l_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine l_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine l_base_bld_mn + + + !> Function bld_en: + !! \memberof psb_l_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine l_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine l_base_bld_en + + + !> Function base_all: + !! \memberof psb_l_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine l_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_l_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine l_base_all + + + !> Function base_mold: + !! \memberof psb_l_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine l_base_mold(x, y, info) + class(psb_l_base_vect_type), intent(in) :: x + class(psb_l_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_l_base_vect_type :: y, stat=info) + + end subroutine l_base_mold + + + module subroutine l_base_reinit(x, info,clear) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + logical :: clear_ + + info = 0 + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + if (clear_) x%v(:) = lzero + call x%set_host() + call x%set_upd() + end if + + end subroutine l_base_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_l_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine l_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine l_base_ins_a + + + module subroutine l_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_l_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,maxr,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine l_base_ins_v + + + + ! + !> Function base_zero + !! \memberof psb_l_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine l_base_zero(x) + class(psb_l_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) then + !$omp workshare + x%v(:)=lzero + !$omp end workshare + end if + call x%set_host() + end subroutine l_base_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_l_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine l_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_lpk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = lzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne. lzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine l_base_asb_m + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_l_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine l_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_lpk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = lzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne. lzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine l_base_asb_e + + + ! + !> Function base_free: + !! \memberof psb_l_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine l_base_free(x, info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) + if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + call x%set_null() + end subroutine l_base_free + + + ! + !> Function base_free_buffer: + !! \memberof psb_l_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + module subroutine l_base_free_buffer(x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine l_base_free_buffer + + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_l_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + module subroutine l_base_maybe_free_buffer(x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine l_base_maybe_free_buffer + + + ! + !> Function base_free_comid: + !! \memberof psb_l_base_vect_type + !! \brief Free aux MPI communication id buffer + !! + !! \param info return code + !! + ! + module subroutine l_base_free_comid(x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine l_base_free_comid + + + module function l_base_get_ncfs(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function l_base_get_ncfs + + module function l_base_get_dupl(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function l_base_get_dupl + + module function l_base_get_state(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function l_base_get_state + + module function l_base_is_null(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function l_base_is_null + + module function l_base_is_bld(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function l_base_is_bld + + module function l_base_is_upd(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function l_base_is_upd + + module function l_base_is_asb(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function l_base_is_asb + + module subroutine l_base_set_ncfs(n,x) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine l_base_set_ncfs + + + module subroutine l_base_set_dupl(n,x) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine l_base_set_dupl + + + module subroutine l_base_set_state(n,x) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine l_base_set_state + + + module subroutine l_base_set_null(x) + class(psb_l_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine l_base_set_null + + + module subroutine l_base_set_bld(x) + class(psb_l_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine l_base_set_bld + + + module subroutine l_base_set_upd(x) + class(psb_l_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine l_base_set_upd + + + module subroutine l_base_set_asb(x) + class(psb_l_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine l_base_set_asb + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_l_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine l_base_sync(x) + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_sync + + + ! + !> Function base_set_host: + !! \memberof psb_l_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine l_base_set_host(x) + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_set_host + + + ! + !> Function base_set_dev: + !! \memberof psb_l_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine l_base_set_dev(x) + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_set_dev + + + ! + !> Function base_set_sync: + !! \memberof psb_l_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine l_base_set_sync(x) + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_set_sync + + + ! + !> Function base_is_dev: + !! \memberof psb_l_base_vect_type + !! \brief Is vector on external device . + !! + ! + module function l_base_is_dev(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function l_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_l_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + module function l_base_is_host(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_l_base_vect_type + !! \brief Is vector on sync . + !! + ! + module function l_base_is_sync(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine l_base_cpy(x, y) + class(psb_l_base_vect_type), intent(in) :: x + class(psb_l_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine l_base_cpy + + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_l_base_vect_type + !! \brief Number of entries + !! + ! + module function l_base_get_nrows(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function l_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_l_base_vect_type + !! \brief Size in bytes + !! + ! + module function l_base_sizeof(x) result(res) + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() + + end function l_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_l_base_vect_type + !! \brief Format + !! + ! + module function l_base_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function l_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_l_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + module function l_base_get_vect(x,n) result(res) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz, i + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + if (.false.) then + res(1:isz) = x%v(1:isz) + else + !$omp parallel do private(i) + do i=1, isz + res(i) = x%v(i) + end do + end if + + end function l_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_l_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine l_base_set_scal(x,val,first,last) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val + end do +#else + x%v(first_:last_) = val +#endif + call x%set_host() + + end subroutine l_base_set_scal + + + + ! + !> Function base_set_vect + !! \memberof psb_l_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine l_base_set_vect(x,val,first,last) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i, info + + if (.not.allocated(x%v)) then + call psb_realloc(size(val),x%v,info) + end if + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val(i-first_+1) + end do +#else + x%v(first_:last_) = val(1:last_-first_+1) +#endif + call x%set_host() + + end subroutine l_base_set_vect + + + module subroutine l_base_check_addr(x) + class(psb_l_base_vect_type), intent(inout) :: x + + write(0,*) 'Check addr: base version, do nothing' + + end subroutine l_base_check_addr + + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_l_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine l_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine l_base_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_l_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine l_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: y(:) + class(psb_l_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine l_base_gthzv_x + + + ! + ! New comm internals impl. + ! + module subroutine l_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_l_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine l_base_gthzbuf + + ! + !> Function base_device_wait: + !! \memberof psb_l_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine l_base_device_wait() + + end subroutine l_base_device_wait + + + module function l_base_use_buffer() result(res) + logical :: res + + res = .true. + end function l_base_use_buffer + + module subroutine l_base_new_buffer(n,x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine l_base_new_buffer + + + module subroutine l_base_new_comid(n,x,info) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine l_base_new_comid + + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_l_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine l_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine l_base_gthzv + + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_l_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine l_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine l_base_sctb + + + module subroutine l_base_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_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine l_base_sctb_x + + + module subroutine l_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta + class(psb_l_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine l_base_sctb_buf + + + +end submodule psb_l_base_vect_impl + + +submodule (psb_l_base_multivect_mod) psb_l_base_multivect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_l_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine l_base_mlv_bld_x(x,this) + integer(psb_lpk_), intent(in) :: this(:,:) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine l_base_mlv_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_l_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine l_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info,scratch=scratch) + + end subroutine l_base_mlv_bld_n + + + !> Function base_mlv_all: + !! \memberof psb_l_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine l_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine l_base_mlv_all + + + !> Function base_mlv_mold: + !! \memberof psb_l_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine l_base_mlv_mold(x, y, info) + class(psb_l_base_multivect_type), intent(in) :: x + class(psb_l_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_l_base_multivect_type :: y, stat=info) + + end subroutine l_base_mlv_mold + + + module subroutine l_base_mlv_reinit(x, info) + class(psb_l_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = lzero + call x%set_host() + call x%set_upd() + end if + + end subroutine l_base_mlv_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_l_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine l_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine l_base_mlv_ins + + + ! + !> Function base_mlv_zero + !! \memberof psb_l_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine l_base_mlv_zero(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=lzero + call x%set_host() + + end subroutine l_base_mlv_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_l_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine l_base_mlv_asb(m,n, x, info, scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_lpk_), allocatable :: vv(:,:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(m,n,vv,info) + vv(:,:) = lzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i),:) = x%v(i,:) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (any(vv(x%iv(i),:).ne.lzero)) then + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') + return + else + vv(x%iv(i),:) = x%v(i,:) + end if + end do + case default + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_l_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine l_base_mlv_free(x, info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine l_base_mlv_free + + + module function l_base_mlv_get_ncfs(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function l_base_mlv_get_ncfs + + module function l_base_mlv_get_dupl(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function l_base_mlv_get_dupl + + module function l_base_mlv_get_state(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function l_base_mlv_get_state + + module function l_base_mlv_is_null(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function l_base_mlv_is_null + + module function l_base_mlv_is_bld(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function l_base_mlv_is_bld + + module function l_base_mlv_is_upd(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function l_base_mlv_is_upd + + module function l_base_mlv_is_asb(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function l_base_mlv_is_asb + + module subroutine l_base_mlv_set_ncfs(n,x) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine l_base_mlv_set_ncfs + + + module subroutine l_base_mlv_set_dupl(n,x) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine l_base_mlv_set_dupl + + + module subroutine l_base_mlv_set_state(n,x) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine l_base_mlv_set_state + + + module subroutine l_base_mlv_set_null(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine l_base_mlv_set_null + + + module subroutine l_base_mlv_set_bld(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine l_base_mlv_set_bld + + + module subroutine l_base_mlv_set_upd(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine l_base_mlv_set_upd + + + module subroutine l_base_mlv_set_asb(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine l_base_mlv_set_asb + + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_l_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine l_base_mlv_sync(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_sync + + + ! + !> Function base_mlv_set_host: + !! \memberof psb_l_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine l_base_mlv_set_host(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_set_host + + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_l_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine l_base_mlv_set_dev(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_set_dev + + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_l_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine l_base_mlv_set_sync(x) + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_set_sync + + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_l_base_multivect_type + !! \brief Is vector on external device . + !! + ! + module function l_base_mlv_is_dev(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function l_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_l_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + module function l_base_mlv_is_host(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_l_base_multivect_type + !! \brief Is vector on sync . + !! + ! + module function l_base_mlv_is_sync(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_mlv_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine l_base_mlv_cpy(x, y) + class(psb_l_base_multivect_type), intent(in) :: x + class(psb_l_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine l_base_mlv_cpy + + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_l_base_multivect_type + !! \brief Number of entries + !! + ! + module function l_base_mlv_get_nrows(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function l_base_mlv_get_nrows + + module function l_base_mlv_get_ncols(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function l_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_l_base_multivect_type + !! \brief Size in bytesa + !! + ! + module function l_base_mlv_sizeof(x) result(res) + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() * x%get_ncols() + + end function l_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_l_base_multivect_type + !! \brief Format + !! + ! + module function l_base_mlv_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function l_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_l_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + module function l_base_mlv_get_vect(x) result(res) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function l_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_l_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine l_base_mlv_set_scal(x,val) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine l_base_mlv_set_scal + + + ! + !> Function base_mlv_set_vect + !! \memberof psb_l_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine l_base_mlv_set_vect(x,val) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine l_base_mlv_set_vect + + + + module function l_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function l_base_mlv_use_buffer + + + module subroutine l_base_mlv_new_buffer(n,x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine l_base_mlv_new_buffer + + + module subroutine l_base_mlv_new_comid(n,x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine l_base_mlv_new_comid + + + + module subroutine l_base_mlv_maybe_free_buffer(x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine l_base_mlv_maybe_free_buffer + + + module subroutine l_base_mlv_free_buffer(x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine l_base_mlv_free_buffer + + + module subroutine l_base_mlv_free_comid(x,info) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine l_base_mlv_free_comid + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine l_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine l_base_mlv_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine l_base_mlv_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_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine l_base_mlv_gthzv_x + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine l_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine l_base_mlv_gthzv + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine l_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: y(:,:) + class(psb_l_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine l_base_mlv_gthzm + + + ! + ! New comm internals impl. + ! + module subroutine l_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_l_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine l_base_mlv_gthzbuf + + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_l_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine l_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine l_base_mlv_sctb + + + module subroutine l_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_lpk_) :: beta, x(:,:) + class(psb_l_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine l_base_mlv_sctbr2 + + + module subroutine l_base_mlv_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_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine l_base_mlv_sctb_x + + + module subroutine l_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta + class(psb_l_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine l_base_mlv_sctb_buf + + + ! + !> Function base_device_wait: + !! \memberof psb_l_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine l_base_mlv_device_wait() + + end subroutine l_base_mlv_device_wait + +end submodule psb_l_base_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 000000000..675207935 --- /dev/null +++ b/base/serial/impl/psb_l_vect_impl.F90 @@ -0,0 +1,902 @@ +! +! 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 psb_base_mod + use psi_serial_mod + implicit none + +contains + + module function l_vect_get_dupl(x) result(res) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + + 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) + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 psb_base_mod + use psi_serial_mod + +contains + + module function l_mvect_get_dupl(x) result(res) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + 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) + + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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_base_vect_impl.F90 b/base/serial/impl/psb_s_base_vect_impl.F90 new file mode 100644 index 000000000..ca313bdff --- /dev/null +++ b/base/serial/impl/psb_s_base_vect_impl.F90 @@ -0,0 +1,3765 @@ +! +! 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_base_vect_mod +! +! This module contains the definition of the psb_s_base_vect type which +! is a container for dense vectors. +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +submodule (psb_s_base_vect_mod) psb_s_base_vect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_s_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine s_base_bld_x(x,this,scratch) + real(psb_spk_), intent(in) :: this(:) + class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + integer(psb_ipk_) :: i + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if +#if defined (PSB_OPENMP) + !$omp parallel do private(i) + do i = 1, size(this) + x%v(i) = this(i) + end do +#else + x%v(:) = this(:) +#endif + end subroutine s_base_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_s_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine s_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine s_base_bld_mn + + + !> Function bld_en: + !! \memberof psb_s_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine s_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine s_base_bld_en + + + !> Function base_all: + !! \memberof psb_s_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine s_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_s_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine s_base_all + + + !> Function base_mold: + !! \memberof psb_s_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine s_base_mold(x, y, info) + class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_s_base_vect_type :: y, stat=info) + + end subroutine s_base_mold + + + module subroutine s_base_reinit(x, info,clear) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + logical :: clear_ + + info = 0 + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + if (clear_) x%v(:) = szero + call x%set_host() + call x%set_upd() + end if + + end subroutine s_base_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_s_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine s_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine s_base_ins_a + + + module subroutine s_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_s_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,maxr,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine s_base_ins_v + + + + ! + !> Function base_zero + !! \memberof psb_s_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine s_base_zero(x) + class(psb_s_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) then + !$omp workshare + x%v(:)=szero + !$omp end workshare + end if + call x%set_host() + end subroutine s_base_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_s_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine s_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_spk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = szero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne. szero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine s_base_asb_m + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_s_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine s_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_spk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = szero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne. szero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine s_base_asb_e + + + ! + !> Function base_free: + !! \memberof psb_s_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine s_base_free(x, info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) + if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + call x%set_null() + end subroutine s_base_free + + + ! + !> Function base_free_buffer: + !! \memberof psb_s_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + module subroutine s_base_free_buffer(x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine s_base_free_buffer + + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_s_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + module subroutine s_base_maybe_free_buffer(x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine s_base_maybe_free_buffer + + + ! + !> Function base_free_comid: + !! \memberof psb_s_base_vect_type + !! \brief Free aux MPI communication id buffer + !! + !! \param info return code + !! + ! + module subroutine s_base_free_comid(x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine s_base_free_comid + + + module function s_base_get_ncfs(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function s_base_get_ncfs + + module function s_base_get_dupl(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function s_base_get_dupl + + module function s_base_get_state(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function s_base_get_state + + module function s_base_is_null(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function s_base_is_null + + module function s_base_is_bld(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function s_base_is_bld + + module function s_base_is_upd(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function s_base_is_upd + + module function s_base_is_asb(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function s_base_is_asb + + module subroutine s_base_set_ncfs(n,x) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine s_base_set_ncfs + + + module subroutine s_base_set_dupl(n,x) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine s_base_set_dupl + + + module subroutine s_base_set_state(n,x) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine s_base_set_state + + + module subroutine s_base_set_null(x) + class(psb_s_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine s_base_set_null + + + module subroutine s_base_set_bld(x) + class(psb_s_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine s_base_set_bld + + + module subroutine s_base_set_upd(x) + class(psb_s_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine s_base_set_upd + + + module subroutine s_base_set_asb(x) + class(psb_s_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine s_base_set_asb + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_s_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine s_base_sync(x) + class(psb_s_base_vect_type), intent(inout) :: x + + end subroutine s_base_sync + + + ! + !> Function base_set_host: + !! \memberof psb_s_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine s_base_set_host(x) + class(psb_s_base_vect_type), intent(inout) :: x + + end subroutine s_base_set_host + + + ! + !> Function base_set_dev: + !! \memberof psb_s_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine s_base_set_dev(x) + class(psb_s_base_vect_type), intent(inout) :: x + + end subroutine s_base_set_dev + + + ! + !> Function base_set_sync: + !! \memberof psb_s_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine s_base_set_sync(x) + class(psb_s_base_vect_type), intent(inout) :: x + + end subroutine s_base_set_sync + + + ! + !> Function base_is_dev: + !! \memberof psb_s_base_vect_type + !! \brief Is vector on external device . + !! + ! + module function s_base_is_dev(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function s_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_s_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + module function s_base_is_host(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function s_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_s_base_vect_type + !! \brief Is vector on sync . + !! + ! + module function s_base_is_sync(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function s_base_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine s_base_cpy(x, y) + class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine s_base_cpy + + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_s_base_vect_type + !! \brief Number of entries + !! + ! + module function s_base_get_nrows(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function s_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_s_base_vect_type + !! \brief Size in bytes + !! + ! + module function s_base_sizeof(x) result(res) + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() + + end function s_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_s_base_vect_type + !! \brief Format + !! + ! + module function s_base_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function s_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_s_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + module function s_base_get_vect(x,n) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz, i + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + if (.false.) then + res(1:isz) = x%v(1:isz) + else + !$omp parallel do private(i) + do i=1, isz + res(i) = x%v(i) + end do + end if + + end function s_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_s_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine s_base_set_scal(x,val,first,last) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val + end do +#else + x%v(first_:last_) = val +#endif + call x%set_host() + + end subroutine s_base_set_scal + + + + ! + !> Function base_set_vect + !! \memberof psb_s_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine s_base_set_vect(x,val,first,last) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i, info + + if (.not.allocated(x%v)) then + call psb_realloc(size(val),x%v,info) + end if + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val(i-first_+1) + end do +#else + x%v(first_:last_) = val(1:last_-first_+1) +#endif + call x%set_host() + + end subroutine s_base_set_vect + + + module subroutine s_base_check_addr(x) + class(psb_s_base_vect_type), intent(inout) :: x + + write(0,*) 'Check addr: base version, do nothing' + + end subroutine s_base_check_addr + + + + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_s_base_vect_type + !! \brief Get one entry from the vector + !! + ! + module function s_base_get_entry(x, index) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: res + + res = szero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if + + end function s_base_get_entry + + module subroutine s_base_set_entry(x, index, val) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + end subroutine s_base_set_entry + + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_s_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine s_base_absval1(x) + class(psb_s_base_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: i + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1, size(x%v) + x%v(i) = abs(x%v(i)) + end do +#else + x%v = abs(x%v) +#endif + call x%set_host() + end if + + end subroutine s_base_absval1 + + + module subroutine s_base_absval2(x,y) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_) :: info + if (.not.x%is_host()) call x%sync() + if (allocated(x%v)) then + call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) + call y%absval() + end if + + end subroutine s_base_absval2 + + + ! + ! Dot products + ! + ! + !> Function base_dot_v + !! \memberof psb_s_base_vect_type + !! \brief Dot product by another base_vector + !! \param n Number of entries to be considered + !! \param y The other (base_vect) to be multiplied by + !! + module function s_base_dot_v(n,x,y) result(res) + class(psb_s_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + real(psb_spk_), external :: sdot + + res = szero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_s_base_vect. + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_s_base_vect_type) + res = sdot(n,x%v,1,y%v,1) + class default + res = y%dot(n,x%v) + end select + + end function s_base_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_dot_a + !! \memberof psb_s_base_vect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function s_base_dot_a(n,x,y) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + real(psb_spk_), external :: sdot + + res = sdot(n,y,1,x%v,1) + + end function s_base_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_axpby_v + !! \memberof psb_s_base_vect_type + !! \brief AXPBY by a (base_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine s_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call y%axpby(m,alpha,x%v,beta,info) + + end subroutine s_base_axpby_v + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_s_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + module subroutine s_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine s_base_axpby_v2 + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_axpby_a + !! \memberof psb_s_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine s_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (y%is_dev()) call y%sync() + call psb_geaxpby(m,alpha,x,beta,y%v,info) + call y%set_host() + + end subroutine s_base_axpby_a + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_s_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + module subroutine s_base_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_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine s_base_axpby_a2 + + + ! + ! UPD_XYZ is invoked via Z, hence the structure below. + ! + ! + !> Function base_upd_xyz + !! \memberof psb_s_base_vect_type + !! \brief UPD_XYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param beta scalar beta + !! \param gamma scalar gamma + !! \param delta scalar delta + !! \param x The class(base_vect) to be added + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be added + !! \param info return code + !! + module subroutine s_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(alpha/=szero)) call x%sync() + if (y%is_dev().and.(beta/=szero)) call y%sync() + if (z%is_dev().and.(delta/=szero)) call z%sync() + call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) + call y%set_host() + call z%set_host() + + end subroutine s_base_upd_xyz + + + module subroutine s_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + class(psb_s_base_vect_type), intent(inout) :: w + real(psb_spk_), intent (in) :: a,b,c,d,e,f + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(a/=szero)) call x%sync() + if (y%is_dev().and.(b/=szero)) call y%sync() + if (z%is_dev().and.(d/=szero)) call z%sync() + if (w%is_dev().and.(f/=szero)) call w%sync() + call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) + call y%set_host() + call z%set_host() + call w%set_host() + + end subroutine s_base_xyzw + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:) = X(:)*Y(:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlt_a + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry multiply by a base_vect array y=x*y + !! \param x The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlt_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine s_base_mlt_v + + + ! + !> Function base_mlt_a + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry multiply by a normal array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlt_a(x, y, info) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)*x(i) + end do + call y%set_host() + + end subroutine s_base_mlt_a + + + + ! + !> Function base_mlt_a_2 + !! \memberof psb_s_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine s_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(z%v), size(x), size(y)) + if (alpha == szero) then + if (beta == sone) then + return + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + end do + end if + else + if (alpha == sone) then + if (beta == szero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = y(i)*x(i) + end do + else if (beta == sone) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) + y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + y(i)*x(i) + end do + end if + else if (alpha == -sone) then + if (beta == szero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = -y(i)*x(i) + end do + else if (beta == sone) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) - y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) - y(i)*x(i) + end do + end if + else + if (beta == szero) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = alpha*y(i)*x(i) + end do + else if (beta == sone) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = z%v(i) + alpha*y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(alpha, beta) + do i=1, n + z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) + end do + end if + end if + end if + call z%set_host() + + end subroutine s_base_mlt_a_2 + + + ! + !> Function base_mlt_v_2 + !! \memberof psb_s_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_vect) to be multiplied b + !! \param y The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_spk_), intent(in) :: alpha,beta + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (y%is_dev()) call y%sync() + if (x%is_dev()) call x%sync() + if (.not.psb_s_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + end if + end subroutine s_base_mlt_v_2 + + + module subroutine s_base_mlt_av(alpha,x,y,beta,z,info) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call z%mlt(alpha,x,y%v,beta,info) + + end subroutine s_base_mlt_av + + + module subroutine s_base_mlt_va(alpha,x,y,beta,z,info) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: y(:) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call z%mlt(alpha,y,x,beta,info) + + end subroutine s_base_mlt_va + + ! + !> Function base_div_v + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine s_base_div_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%div(x%v,info) + + end subroutine s_base_div_v + + + module subroutine s_base_div_a(x, y, info) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)/x(i) + end do + call y%set_host() + + end subroutine s_base_div_a + + ! + !> Function base_div_v2 + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine s_base_div_v2(x, y, z, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call z%div(x%v,y%v,info) + call z%set_host() + end subroutine s_base_div_v2 + + ! + !> Function base_div_v_check + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine s_base_div_v_check(x, y, info, flag) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call x%div(x%v,y%v,info,flag) + + end subroutine s_base_div_v_check + + ! + !> Function base_div_v2_check + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine s_base_div_v2_check(x, y, z, info, flag) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + end subroutine s_base_div_v2_check + + ! + !> Function base_div_a2 + !! \memberof psb_s_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + module subroutine s_base_div_a2(x, y, z, info) + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + !$omp parallel do private(i) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine s_base_div_a2 + + ! + !> Function base_div_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + module subroutine s_base_div_a2_check(x, y, z, info, flag) + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call s_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + ! $omp parallel do private(i) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine s_base_div_a2_check + + ! + !> Function base_inv_v + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + module subroutine s_base_inv_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine s_base_inv_v + + ! + !> Function base_inv_v_check + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + module subroutine s_base_inv_v_check(x, y, info, flag) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + end subroutine s_base_inv_v_check + + ! + !> Function base_inv_a2 + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + module subroutine s_base_inv_a2(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + y%v(i) = 1_psb_spk_/x(i) + end do + + end subroutine s_base_inv_a2 + + ! + !> Function base_inv_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + module subroutine s_base_inv_a2_check(x, y, info, flag) + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call s_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_spk_/x(i) + else + info = 1 + y%v(i) = 0_psb_spk_ + end if + end do + end if + + + end subroutine s_base_inv_a2_check + + + ! + !> Function base_inv_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine s_base_acmp_a2(x,c,z,info) + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + !$omp parallel do private(i) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_spk_ + else + z%v(i) = 0_psb_spk_ + end if + end do + info = 0 + + end subroutine s_base_acmp_a2 + + ! + !> Function base_cmp_v2 + !! \memberof psb_s_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine s_base_acmp_v2(x,c,z,info) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine s_base_acmp_v2 + + + ! + ! Simple scaling + ! + !> Function base_scal + !! \memberof psb_s_base_vect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! + module subroutine s_base_scal(alpha, x) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent (in) :: alpha + integer(psb_ipk_) :: i + + if (allocated(x%v)) then +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1,size(x%v) + x%v(i) = alpha*x%v(i) + end do +#else + x%v = alpha*x%v +#endif + end if + call x%set_host() + end subroutine s_base_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_nrm2 + !! \memberof psb_s_base_vect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function s_base_nrm2(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + real(psb_spk_), external :: snrm2 + + if (x%is_dev()) call x%sync() + res = snrm2(n,x%v,1) + + end function s_base_nrm2 + + ! + !> Function base_amax + !! \memberof psb_s_base_vect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function s_base_amax(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res = szero + !$omp parallel do private(i) reduction(max: res) + do i=1, n + res = max(res,abs(x%v(i))) + end do +#else + res = maxval(abs(x%v(1:n))) +#endif + end function s_base_amax + + ! + !> Function base_min + !! \memberof psb_s_base_vect_type + !! \brief min x(1:n) + !! \param n how many entries to consider + module function s_base_min(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res = HUGE(sone) + !$omp parallel do private(i) reduction(min: res) + do i=1, n + res = min(res,abs(x%v(i))) + end do +#else + ! + ! From M&R&C: if the array is of size zero, MINVAL + ! returns the largest positive value + ! + res = minval(x%v(1:n)) +#endif + end function s_base_min + + ! + !> Function base_minquotient_v + !! \memberof psb_s_base_vect_type + !! \brief Minimum entry of the vector entry-by-entry divide x/y + !! \param x The numerator vector + !! \param y The denumerator vector + !! \param info return code + !! + module function s_base_minquotient_v(x, y, info) result(z) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + + z = x%minquotient(y%v,info) + + end function s_base_minquotient_v + + ! + !> Function base_minquotient_a2 + !! \memberof psb_s_base_vect_type + !! \brief Minimum entry of the array entry-by-entry divide x/y + !! \param x The numerator array + !! \param y The denumerator array + !! \param info return code + !! + module function s_base_minquotient_a2(x, y, info) result(z) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + real(psb_spk_) :: temp + + info = 0 + + z = huge(z) + n = min(size(y), size(x%v)) + !$omp parallel do private(i,temp) reduction(min: z) + do i=1, n + if ( y(i) /= szero ) then + temp = x%v(i)/y(i) + z = min(z,temp) + end if + end do + + end function s_base_minquotient_a2 + + + ! + !> Function base_asum + !! \memberof psb_s_base_vect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function s_base_asum(n,x) result(res) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res=szero + !$omp parallel do private(i) reduction(+: res) + do i= 1, size(x%v) + res = res + abs(x%v(i)) + end do +#else + res = sum(abs(x%v(1:n))) +#endif + end function s_base_asum + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_s_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine s_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine s_base_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_s_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine s_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: y(:) + class(psb_s_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine s_base_gthzv_x + + + ! + ! New comm internals impl. + ! + module subroutine s_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_s_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine s_base_gthzbuf + + ! + !> Function base_device_wait: + !! \memberof psb_s_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine s_base_device_wait() + + end subroutine s_base_device_wait + + + module function s_base_use_buffer() result(res) + logical :: res + + res = .true. + end function s_base_use_buffer + + module subroutine s_base_new_buffer(n,x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine s_base_new_buffer + + + module subroutine s_base_new_comid(n,x,info) + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine s_base_new_comid + + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_s_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine s_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine s_base_gthzv + + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_s_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine s_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine s_base_sctb + + + module subroutine s_base_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_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine s_base_sctb_x + + + module subroutine s_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta + class(psb_s_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine s_base_sctb_buf + + + ! + !> Function base_mask_a + !! \memberof psb_s_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The array to be compared + !! \param c The array containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + module subroutine s_base_mask_a(c,x,m,t,info) + real(psb_spk_), intent(inout) :: c(:) + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + integer(psb_ipk_) :: i, n + + if (m%is_dev()) call m%sync() + t = .true. + + n = size(x) + do i = 1, n, 1 + if (c(i).eq.2_psb_spk_) then + if ( x(i) > szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + elseif (c(i).eq.1_psb_spk_) then + if ( x(i) >= szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + elseif (c(i).eq.-1_psb_spk_) then + if ( x(i) <= szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + elseif (c(i).eq.-2_psb_spk_) then + if ( x(i) < szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + else + m%v(i) = 0_psb_spk_ + end if + end do + info = 0 + + end subroutine s_base_mask_a + + ! + !> Function base_mask_v + !! \memberof psb_s_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The vector to be compared + !! \param c The vector containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + module subroutine s_base_mask_v(c,x,m,t,info) + class(psb_s_base_vect_type), intent(inout) :: c + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + + info = 0 + if (x%is_dev()) call x%sync() + if (c%is_dev()) call c%sync() + + call m%mask(x%v,c%v,t,info) + end subroutine s_base_mask_v + + + + ! + !> Function _base_addconst_a2 + !! \memberof psb_s_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine s_base_addconst_a2(x,b,z,info) + real(psb_spk_), intent(in) :: b + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() +#if defined(PSB_OPENMP) + n = size(x) + !$omp parallel do private(i) + do i = 1, n + z%v(i) = x(i) + b + end do +#else + z%v = x + b +#endif + info = 0 + + end subroutine s_base_addconst_a2 + + ! + !> Function _base_addconst_v2 + !! \memberof psb_s_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine s_base_addconst_v2(x,b,z,info) + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: b + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine s_base_addconst_v2 + +end submodule psb_s_base_vect_impl + + +submodule (psb_s_base_multivect_mod) psb_s_base_multivect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_s_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine s_base_mlv_bld_x(x,this) + real(psb_spk_), intent(in) :: this(:,:) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine s_base_mlv_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_s_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine s_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info,scratch=scratch) + + end subroutine s_base_mlv_bld_n + + + !> Function base_mlv_all: + !! \memberof psb_s_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine s_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine s_base_mlv_all + + + !> Function base_mlv_mold: + !! \memberof psb_s_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine s_base_mlv_mold(x, y, info) + class(psb_s_base_multivect_type), intent(in) :: x + class(psb_s_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_s_base_multivect_type :: y, stat=info) + + end subroutine s_base_mlv_mold + + + module subroutine s_base_mlv_reinit(x, info) + class(psb_s_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = szero + call x%set_host() + call x%set_upd() + end if + + end subroutine s_base_mlv_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_s_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine s_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine s_base_mlv_ins + + + ! + !> Function base_mlv_zero + !! \memberof psb_s_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine s_base_mlv_zero(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=szero + call x%set_host() + + end subroutine s_base_mlv_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_s_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine s_base_mlv_asb(m,n, x, info, scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + real(psb_spk_), allocatable :: vv(:,:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(m,n,vv,info) + vv(:,:) = szero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i),:) = x%v(i,:) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (any(vv(x%iv(i),:).ne.szero)) then + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') + return + else + vv(x%iv(i),:) = x%v(i,:) + end if + end do + case default + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_s_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine s_base_mlv_free(x, info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine s_base_mlv_free + + + module function s_base_mlv_get_ncfs(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function s_base_mlv_get_ncfs + + module function s_base_mlv_get_dupl(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function s_base_mlv_get_dupl + + module function s_base_mlv_get_state(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function s_base_mlv_get_state + + module function s_base_mlv_is_null(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function s_base_mlv_is_null + + module function s_base_mlv_is_bld(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function s_base_mlv_is_bld + + module function s_base_mlv_is_upd(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function s_base_mlv_is_upd + + module function s_base_mlv_is_asb(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function s_base_mlv_is_asb + + module subroutine s_base_mlv_set_ncfs(n,x) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine s_base_mlv_set_ncfs + + + module subroutine s_base_mlv_set_dupl(n,x) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine s_base_mlv_set_dupl + + + module subroutine s_base_mlv_set_state(n,x) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine s_base_mlv_set_state + + + module subroutine s_base_mlv_set_null(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine s_base_mlv_set_null + + + module subroutine s_base_mlv_set_bld(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine s_base_mlv_set_bld + + + module subroutine s_base_mlv_set_upd(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine s_base_mlv_set_upd + + + module subroutine s_base_mlv_set_asb(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine s_base_mlv_set_asb + + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_s_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine s_base_mlv_sync(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + end subroutine s_base_mlv_sync + + + ! + !> Function base_mlv_set_host: + !! \memberof psb_s_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine s_base_mlv_set_host(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + end subroutine s_base_mlv_set_host + + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_s_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine s_base_mlv_set_dev(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + end subroutine s_base_mlv_set_dev + + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_s_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine s_base_mlv_set_sync(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + end subroutine s_base_mlv_set_sync + + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_s_base_multivect_type + !! \brief Is vector on external device . + !! + ! + module function s_base_mlv_is_dev(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function s_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_s_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + module function s_base_mlv_is_host(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function s_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_s_base_multivect_type + !! \brief Is vector on sync . + !! + ! + module function s_base_mlv_is_sync(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function s_base_mlv_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine s_base_mlv_cpy(x, y) + class(psb_s_base_multivect_type), intent(in) :: x + class(psb_s_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine s_base_mlv_cpy + + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_s_base_multivect_type + !! \brief Number of entries + !! + ! + module function s_base_mlv_get_nrows(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function s_base_mlv_get_nrows + + module function s_base_mlv_get_ncols(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function s_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_s_base_multivect_type + !! \brief Size in bytesa + !! + ! + module function s_base_mlv_sizeof(x) result(res) + class(psb_s_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() * x%get_ncols() + + end function s_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_s_base_multivect_type + !! \brief Format + !! + ! + module function s_base_mlv_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function s_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_s_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + module function s_base_mlv_get_vect(x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function s_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_s_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine s_base_mlv_set_scal(x,val) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine s_base_mlv_set_scal + + + ! + !> Function base_mlv_set_vect + !! \memberof psb_s_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine s_base_mlv_set_vect(x,val) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine s_base_mlv_set_vect + + + ! + ! Dot products + ! + ! + !> Function base_mlv_dot_v + !! \memberof psb_s_base_multivect_type + !! \brief Dot product by another base_mlv_vector + !! \param n Number of entries to be considered + !! \param y The other (base_mlv_vect) to be multiplied by + !! + module function s_base_mlv_dot_v(n,x,y) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + real(psb_spk_), external :: sdot + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + res = szero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_s_base_mlv_vect (or its class does not care). + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_s_base_multivect_type) + if (y%is_dev()) call y%sync() + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = sdot(n,x%v(:,j),1,y%v(:,j),1) + end do + class default + res = y%dot(n,x%v) + end select + + end function s_base_mlv_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_mlv_dot_a + !! \memberof psb_s_base_multivect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function s_base_mlv_dot_a(n,x,y) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + real(psb_spk_), external :: sdot + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = sdot(n,x%v(:,j),1,y(:,j),1) + end do + + end function s_base_mlv_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_mlv_axpby_v + !! \memberof psb_s_base_multivect_type + !! \brief AXPBY by a (base_mlv_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_mlv_vect) to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine s_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + + if (present(n)) then + nc = n + else + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + end if + select type(xx => x) + type is (psb_s_base_multivect_type) + call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) + class default + call y%axpby(m,alpha,x%v,beta,info,n=n) + end select + + end subroutine s_base_mlv_axpby_v + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_mlv_axpby_a + !! \memberof psb_s_base_multivect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine s_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:,:) + class(psb_s_base_multivect_type), intent(inout) :: y + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + if (present(n)) then + nc = n + else + nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) + end if + + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) + + end subroutine s_base_mlv_axpby_a + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlv_mlt_mv + !! \memberof psb_s_base_multivect_type + !! \brief Multivector entry-by-entry multiply by a base_mlv_multivect y=x*y + !! \param x The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlv_mlt_mv(x, y, info) + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine s_base_mlv_mlt_mv + + + module subroutine s_base_mlv_mlt_mv_v(x, y, info) + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine s_base_mlv_mlt_mv_v + + + ! + !> Function base_mlv_mlt_ar1 + !! \memberof psb_s_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 1 array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlv_mlt_ar1(x, y, info) + real(psb_spk_), intent(in) :: x(:) + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + n = min(psb_size(y%v,1_psb_ipk_), size(x)) + do i=1, n + y%v(i,:) = y%v(i,:)*x(i) + end do + + end subroutine s_base_mlv_mlt_ar1 + + + ! + !> Function base_mlv_mlt_ar2 + !! \memberof psb_s_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 2 array y=x*y + !! \param x(:,:) The array to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlv_mlt_ar2(x, y, info) + real(psb_spk_), intent(in) :: x(:,:) + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr,nc + + info = 0 + nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) + nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) + y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) + + end subroutine s_base_mlv_mlt_ar2 + + + + ! + !> Function base_mlv_mlt_a_2 + !! \memberof psb_s_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr, nc + + info = 0 + nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == szero) then + if (beta == sone) then + return + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + end if + else + if (alpha == sone) then + if (beta == szero) then + z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == sone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else if (alpha == -sone) then + if (beta == szero) then + z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == sone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else + if (beta == szero) then + z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == sone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + end if + end if + end if + end subroutine s_base_mlv_mlt_a_2 + + + ! + !> Function base_mlv_mlt_v_2 + !! \memberof psb_s_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_mlv_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_mlv_vect) to be multiplied b + !! \param y The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine s_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + real(psb_spk_), intent(in) :: alpha,beta + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_s_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + if (z%is_dev()) call z%sync() + if (.not.psb_s_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=(x%v) + if (conjgy_) y%v=(y%v) + end if + end subroutine s_base_mlv_mlt_v_2 + +!!$ +!!$ subroutine s_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ real(psb_spk_), intent(in) :: alpha,beta +!!$ real(psb_spk_), intent(in) :: x(:) +!!$ class(psb_s_base_multivect_type), intent(inout) :: y +!!$ class(psb_s_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine s_base_mlv_mlt_av + +!!$ +!!$ subroutine s_base_mlv_mlt_va(alpha,x,y,beta,z,info) +!!$ real(psb_spk_), intent(in) :: alpha,beta +!!$ real(psb_spk_), intent(in) :: y(:) +!!$ class(psb_s_base_multivect_type), intent(inout) :: x +!!$ class(psb_s_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,y,x,beta,info) +!!$ +!!$ end subroutine s_base_mlv_mlt_va + +!!$ +!!$ + ! + ! Simple scaling + ! + !> Function base_mlv_scal + !! \memberof psb_s_base_multivect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! +module subroutine s_base_mlv_scal(alpha, x) + class(psb_s_base_multivect_type), intent(inout) :: x + real(psb_spk_), intent (in) :: alpha + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) x%v = alpha*x%v + + end subroutine s_base_mlv_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_mlv_nrm2 + !! \memberof psb_s_base_multivect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function s_base_mlv_nrm2(n,x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + real(psb_spk_), external :: snrm2 + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = snrm2(n,x%v(:,j),1) + end do + + end function s_base_mlv_nrm2 + + + ! + !> Function base_mlv_amax + !! \memberof psb_s_base_multivect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function s_base_mlv_amax(n,x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = maxval(abs(x%v(1:n,j))) + end do + + end function s_base_mlv_amax + + + ! + !> Function base_mlv_asum + !! \memberof psb_s_base_multivect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function s_base_mlv_asum(n,x) result(res) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = sum(abs(x%v(1:n,j))) + end do + + end function s_base_mlv_asum + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_s_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine s_base_mlv_absval1(x) + class(psb_s_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v = abs(x%v) + call x%set_host() + end if + + end subroutine s_base_mlv_absval1 + + + module subroutine s_base_mlv_absval2(x,y) + class(psb_s_base_multivect_type), intent(inout) :: x + class(psb_s_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) then + call y%axpby(min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) + call y%absval() + end if + + end subroutine s_base_mlv_absval2 + + + + module function s_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function s_base_mlv_use_buffer + + + module subroutine s_base_mlv_new_buffer(n,x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine s_base_mlv_new_buffer + + + module subroutine s_base_mlv_new_comid(n,x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine s_base_mlv_new_comid + + + + module subroutine s_base_mlv_maybe_free_buffer(x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine s_base_mlv_maybe_free_buffer + + + module subroutine s_base_mlv_free_buffer(x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine s_base_mlv_free_buffer + + + module subroutine s_base_mlv_free_comid(x,info) + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine s_base_mlv_free_comid + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_s_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine s_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine s_base_mlv_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_s_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine s_base_mlv_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_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine s_base_mlv_gthzv_x + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_s_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine s_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:) + class(psb_s_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine s_base_mlv_gthzv + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_s_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine s_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: y(:,:) + class(psb_s_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine s_base_mlv_gthzm + + + ! + ! New comm internals impl. + ! + module subroutine s_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_s_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine s_base_mlv_gthzbuf + + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_s_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine s_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine s_base_mlv_sctb + + + module subroutine s_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + real(psb_spk_) :: beta, x(:,:) + class(psb_s_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine s_base_mlv_sctbr2 + + + module subroutine s_base_mlv_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_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine s_base_mlv_sctb_x + + + module subroutine s_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta + class(psb_s_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine s_base_mlv_sctb_buf + + + ! + !> Function base_device_wait: + !! \memberof psb_s_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine s_base_mlv_device_wait() + + end subroutine s_base_mlv_device_wait + +end submodule psb_s_base_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 000000000..50e37a3f6 --- /dev/null +++ b/base/serial/impl/psb_s_vect_impl.F90 @@ -0,0 +1,1690 @@ +! +! 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 psb_base_mod + use psi_serial_mod + implicit none + +contains + + module function s_vect_get_dupl(x) result(res) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + + 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) + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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%div(x%v,info) + + end subroutine s_vect_div_v + + 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 + 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) + 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%div(x%v,info,flag) + + end subroutine s_vect_div_v_check + + 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 + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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(sone) + end if + + end function s_vect_min + + 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 + + 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) + 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) + 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) + 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) + 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) + 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 psb_base_mod + use psi_serial_mod + +contains + + module function s_mvect_get_dupl(x) result(res) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + 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) + + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) +!!$ 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 +!!$ +!!$ function s_mvect_dot_a(n,x,y) result(res) +!!$ 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) +!!$ 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 +!!$ +!!$ subroutine s_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine s_mvect_mlt_v(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 +!!$ 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 +!!$ +!!$ subroutine s_mvect_mlt_a(x, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine s_mvect_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_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 +!!$ +!!$ subroutine s_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ 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 +!!$ +!!$ subroutine s_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine s_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine s_mvect_scal(alpha, x) +!!$ 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 +!!$ +!!$ +!!$ function s_mvect_nrm2(n,x) result(res) +!!$ 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 +!!$ +!!$ function s_mvect_amax(n,x) result(res) +!!$ 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 +!!$ +!!$ function s_mvect_asum(n,x) result(res) +!!$ 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_base_vect_impl.F90 b/base/serial/impl/psb_z_base_vect_impl.F90 new file mode 100644 index 000000000..0fc8d81d0 --- /dev/null +++ b/base/serial/impl/psb_z_base_vect_impl.F90 @@ -0,0 +1,3596 @@ +! +! 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_base_vect_mod +! +! This module contains the definition of the psb_z_base_vect type which +! is a container for dense vectors. +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +submodule (psb_z_base_vect_mod) psb_z_base_vect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_z_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine z_base_bld_x(x,this,scratch) + complex(psb_dpk_), intent(in) :: this(:) + class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + integer(psb_ipk_) :: i + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if +#if defined (PSB_OPENMP) + !$omp parallel do private(i) + do i = 1, size(this) + x%v(i) = this(i) + end do +#else + x%v(:) = this(:) +#endif + end subroutine z_base_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_z_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine z_base_bld_mn(x,n,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine z_base_bld_mn + + + !> Function bld_en: + !! \memberof psb_z_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine z_base_bld_en(x,n,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine z_base_bld_en + + + !> Function base_all: + !! \memberof psb_z_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine z_base_all(n, x, info) + integer(psb_ipk_), intent(in) :: n + class(psb_z_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine z_base_all + + + !> Function base_mold: + !! \memberof psb_z_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine z_base_mold(x, y, info) + class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_z_base_vect_type :: y, stat=info) + + end subroutine z_base_mold + + + module subroutine z_base_reinit(x, info,clear) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + logical :: clear_ + + info = 0 + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + if (clear_) x%v(:) = zzero + call x%set_host() + call x%set_upd() + end if + + end subroutine z_base_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_z_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine z_base_ins_a(n,irl,val,dupl,x,maxr,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine z_base_ins_a + + + module subroutine z_base_ins_v(n,irl,val,dupl,x,maxr,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_z_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,maxr,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine z_base_ins_v + + + + ! + !> Function base_zero + !! \memberof psb_z_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine z_base_zero(x) + class(psb_z_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) then + !$omp workshare + x%v(:)=zzero + !$omp end workshare + end if + call x%set_host() + end subroutine z_base_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_z_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine z_base_asb_m(n, x, info, scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_dpk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = zzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne. zzero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine z_base_asb_m + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_z_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine z_base_asb_e(n, x, info, scratch) + integer(psb_epk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_dpk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = zzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne. zzero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine z_base_asb_e + + + ! + !> Function base_free: + !! \memberof psb_z_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine z_base_free(x, info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) + if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + call x%set_null() + end subroutine z_base_free + + + ! + !> Function base_free_buffer: + !! \memberof psb_z_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + module subroutine z_base_free_buffer(x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine z_base_free_buffer + + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_z_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + module subroutine z_base_maybe_free_buffer(x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine z_base_maybe_free_buffer + + + ! + !> Function base_free_comid: + !! \memberof psb_z_base_vect_type + !! \brief Free aux MPI communication id buffer + !! + !! \param info return code + !! + ! + module subroutine z_base_free_comid(x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine z_base_free_comid + + + module function z_base_get_ncfs(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function z_base_get_ncfs + + module function z_base_get_dupl(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function z_base_get_dupl + + module function z_base_get_state(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function z_base_get_state + + module function z_base_is_null(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function z_base_is_null + + module function z_base_is_bld(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function z_base_is_bld + + module function z_base_is_upd(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function z_base_is_upd + + module function z_base_is_asb(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function z_base_is_asb + + module subroutine z_base_set_ncfs(n,x) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine z_base_set_ncfs + + + module subroutine z_base_set_dupl(n,x) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine z_base_set_dupl + + + module subroutine z_base_set_state(n,x) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine z_base_set_state + + + module subroutine z_base_set_null(x) + class(psb_z_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine z_base_set_null + + + module subroutine z_base_set_bld(x) + class(psb_z_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine z_base_set_bld + + + module subroutine z_base_set_upd(x) + class(psb_z_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine z_base_set_upd + + + module subroutine z_base_set_asb(x) + class(psb_z_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine z_base_set_asb + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_z_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine z_base_sync(x) + class(psb_z_base_vect_type), intent(inout) :: x + + end subroutine z_base_sync + + + ! + !> Function base_set_host: + !! \memberof psb_z_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine z_base_set_host(x) + class(psb_z_base_vect_type), intent(inout) :: x + + end subroutine z_base_set_host + + + ! + !> Function base_set_dev: + !! \memberof psb_z_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine z_base_set_dev(x) + class(psb_z_base_vect_type), intent(inout) :: x + + end subroutine z_base_set_dev + + + ! + !> Function base_set_sync: + !! \memberof psb_z_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine z_base_set_sync(x) + class(psb_z_base_vect_type), intent(inout) :: x + + end subroutine z_base_set_sync + + + ! + !> Function base_is_dev: + !! \memberof psb_z_base_vect_type + !! \brief Is vector on external device . + !! + ! + module function z_base_is_dev(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function z_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_z_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + module function z_base_is_host(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function z_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_z_base_vect_type + !! \brief Is vector on sync . + !! + ! + module function z_base_is_sync(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function z_base_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine z_base_cpy(x, y) + class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine z_base_cpy + + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_z_base_vect_type + !! \brief Number of entries + !! + ! + module function z_base_get_nrows(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function z_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_z_base_vect_type + !! \brief Size in bytes + !! + ! + module function z_base_sizeof(x) result(res) + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() + + end function z_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_z_base_vect_type + !! \brief Format + !! + ! + module function z_base_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function z_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_z_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + module function z_base_get_vect(x,n) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz, i + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + if (.false.) then + res(1:isz) = x%v(1:isz) + else + !$omp parallel do private(i) + do i=1, isz + res(i) = x%v(i) + end do + end if + + end function z_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_z_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine z_base_set_scal(x,val,first,last) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val + end do +#else + x%v(first_:last_) = val +#endif + call x%set_host() + + end subroutine z_base_set_scal + + + + ! + !> Function base_set_vect + !! \memberof psb_z_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine z_base_set_vect(x,val,first,last) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i, info + + if (.not.allocated(x%v)) then + call psb_realloc(size(val),x%v,info) + end if + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val(i-first_+1) + end do +#else + x%v(first_:last_) = val(1:last_-first_+1) +#endif + call x%set_host() + + end subroutine z_base_set_vect + + + module subroutine z_base_check_addr(x) + class(psb_z_base_vect_type), intent(inout) :: x + + write(0,*) 'Check addr: base version, do nothing' + + end subroutine z_base_check_addr + + + + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_z_base_vect_type + !! \brief Get one entry from the vector + !! + ! + module function z_base_get_entry(x, index) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: res + + res = zzero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if + + end function z_base_get_entry + + module subroutine z_base_set_entry(x, index, val) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + end subroutine z_base_set_entry + + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_z_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine z_base_absval1(x) + class(psb_z_base_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: i + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1, size(x%v) + x%v(i) = abs(x%v(i)) + end do +#else + x%v = abs(x%v) +#endif + call x%set_host() + end if + + end subroutine z_base_absval1 + + + module subroutine z_base_absval2(x,y) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_) :: info + if (.not.x%is_host()) call x%sync() + if (allocated(x%v)) then + call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) + call y%absval() + end if + + end subroutine z_base_absval2 + + + ! + ! Dot products + ! + ! + !> Function base_dot_v + !! \memberof psb_z_base_vect_type + !! \brief Dot product by another base_vector + !! \param n Number of entries to be considered + !! \param y The other (base_vect) to be multiplied by + !! + module function z_base_dot_v(n,x,y) result(res) + class(psb_z_base_vect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + complex(psb_dpk_), external :: zdotc + + res = zzero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_z_base_vect. + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_z_base_vect_type) + res = zdotc(n,x%v,1,y%v,1) + class default + res = y%dot(n,x%v) + end select + + end function z_base_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_dot_a + !! \memberof psb_z_base_vect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function z_base_dot_a(n,x,y) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_) :: res + complex(psb_dpk_), external :: zdotc + + res = zdotc(n,y,1,x%v,1) + + end function z_base_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_axpby_v + !! \memberof psb_z_base_vect_type + !! \brief AXPBY by a (base_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine z_base_axpby_v(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call y%axpby(m,alpha,x%v,beta,info) + + end subroutine z_base_axpby_v + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_z_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar beta + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + module subroutine z_base_axpby_v2(m,alpha, x, beta, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine z_base_axpby_v2 + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_axpby_a + !! \memberof psb_z_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param info return code + !! + module subroutine z_base_axpby_a(m,alpha, x, beta, y, info) + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (y%is_dev()) call y%sync() + call psb_geaxpby(m,alpha,x,beta,y%v,info) + call y%set_host() + + end subroutine z_base_axpby_a + + + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_z_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + module subroutine z_base_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_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine z_base_axpby_a2 + + + ! + ! UPD_XYZ is invoked via Z, hence the structure below. + ! + ! + !> Function base_upd_xyz + !! \memberof psb_z_base_vect_type + !! \brief UPD_XYZ combines two AXPBYS y=alpha*x+beta*y, z=gamma*y+delta*zeta + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param beta scalar beta + !! \param gamma scalar gamma + !! \param delta scalar delta + !! \param x The class(base_vect) to be added + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be added + !! \param info return code + !! + module subroutine z_base_upd_xyz(m,alpha, beta, gamma,delta,x, y, z, info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta, gamma, delta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(alpha/=zzero)) call x%sync() + if (y%is_dev().and.(beta/=zzero)) call y%sync() + if (z%is_dev().and.(delta/=zzero)) call z%sync() + call psi_upd_xyz(m,alpha, beta, gamma,delta,x%v, y%v, z%v, info) + call y%set_host() + call z%set_host() + + end subroutine z_base_upd_xyz + + + module subroutine z_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + class(psb_z_base_vect_type), intent(inout) :: w + complex(psb_dpk_), intent (in) :: a,b,c,d,e,f + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev().and.(a/=zzero)) call x%sync() + if (y%is_dev().and.(b/=zzero)) call y%sync() + if (z%is_dev().and.(d/=zzero)) call z%sync() + if (w%is_dev().and.(f/=zzero)) call w%sync() + call psi_xyzw(m,a,b,c,d,e,f,x%v, y%v, z%v, w%v, info) + call y%set_host() + call z%set_host() + call w%set_host() + + end subroutine z_base_xyzw + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:) = X(:)*Y(:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlt_a + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry multiply by a base_vect array y=x*y + !! \param x The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlt_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine z_base_mlt_v + + + ! + !> Function base_mlt_a + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry multiply by a normal array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlt_a(x, y, info) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)*x(i) + end do + call y%set_host() + + end subroutine z_base_mlt_a + + + + ! + !> Function base_mlt_a_2 + !! \memberof psb_z_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine z_base_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_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(z%v), size(x), size(y)) + if (alpha == zzero) then + if (beta == zone) then + return + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + end do + end if + else + if (alpha == zone) then + if (beta == zzero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = y(i)*x(i) + end do + else if (beta == zone) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) + y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) + y(i)*x(i) + end do + end if + else if (alpha == -zone) then + if (beta == zzero) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = -y(i)*x(i) + end do + else if (beta == zone) then + !$omp parallel do private(i) + do i=1, n + z%v(i) = z%v(i) - y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(beta) + do i=1, n + z%v(i) = beta*z%v(i) - y(i)*x(i) + end do + end if + else + if (beta == zzero) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = alpha*y(i)*x(i) + end do + else if (beta == zone) then + !$omp parallel do private(i) shared(alpha) + do i=1, n + z%v(i) = z%v(i) + alpha*y(i)*x(i) + end do + else + !$omp parallel do private(i) shared(alpha, beta) + do i=1, n + z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) + end do + end if + end if + end if + call z%set_host() + + end subroutine z_base_mlt_a_2 + + + ! + !> Function base_mlt_v_2 + !! \memberof psb_z_base_vect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_vect) to be multiplied b + !! \param y The class(base_vect) to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_dpk_), intent(in) :: alpha,beta + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (y%is_dev()) call y%sync() + if (x%is_dev()) call x%sync() + if (.not.psb_z_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + end if + end subroutine z_base_mlt_v_2 + + + module subroutine z_base_mlt_av(alpha,x,y,beta,z,info) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call z%mlt(alpha,x,y%v,beta,info) + + end subroutine z_base_mlt_av + + + module subroutine z_base_mlt_va(alpha,x,y,beta,z,info) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call z%mlt(alpha,y,x,beta,info) + + end subroutine z_base_mlt_va + + ! + !> Function base_div_v + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine z_base_div_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + call y%div(x%v,info) + + end subroutine z_base_div_v + + + module subroutine z_base_div_a(x, y, info) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + n = min(size(y%v), size(x)) + !$omp parallel do private(i) + do i=1, n + y%v(i) = y%v(i)/x(i) + end do + call y%set_host() + + end subroutine z_base_div_a + + ! + !> Function base_div_v2 + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine z_base_div_v2(x, y, z, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call z%div(x%v,y%v,info) + call z%set_host() + end subroutine z_base_div_v2 + + ! + !> Function base_div_v_check + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine z_base_div_v_check(x, y, info, flag) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + call x%div(x%v,y%v,info,flag) + + end subroutine z_base_div_v_check + + ! + !> Function base_div_v2_check + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + module subroutine z_base_div_v2_check(x, y, z, info, flag) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + end subroutine z_base_div_v2_check + + ! + !> Function base_div_a2 + !! \memberof psb_z_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + module subroutine z_base_div_a2(x, y, z, info) + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + !$omp parallel do private(i) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine z_base_div_a2 + + ! + !> Function base_div_a2_check + !! \memberof psb_z_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + module subroutine z_base_div_a2_check(x, y, z, info, flag) + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call z_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + ! $omp parallel do private(i) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + end subroutine z_base_div_a2_check + + ! + !> Function base_inv_v + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + module subroutine z_base_inv_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine z_base_inv_v + + ! + !> Function base_inv_v_check + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + module subroutine z_base_inv_v_check(x, y, info, flag) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + end subroutine z_base_inv_v_check + + ! + !> Function base_inv_a2 + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + module subroutine z_base_inv_a2(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + y%v(i) = 1_psb_dpk_/x(i) + end do + + end subroutine z_base_inv_a2 + + ! + !> Function base_inv_a2_check + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + module subroutine z_base_inv_a2_check(x, y, info, flag) + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call z_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + !$omp parallel do private(i) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_dpk_/x(i) + else + info = 1 + y%v(i) = 0_psb_dpk_ + end if + end do + end if + + + end subroutine z_base_inv_a2_check + + + ! + !> Function base_inv_a2_check + !! \memberof psb_z_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine z_base_acmp_a2(x,c,z,info) + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + !$omp parallel do private(i) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_dpk_ + else + z%v(i) = 0_psb_dpk_ + end if + end do + info = 0 + + end subroutine z_base_acmp_a2 + + ! + !> Function base_cmp_v2 + !! \memberof psb_z_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + module subroutine z_base_acmp_v2(x,c,z,info) + class(psb_z_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine z_base_acmp_v2 + + + ! + ! Simple scaling + ! + !> Function base_scal + !! \memberof psb_z_base_vect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! + module subroutine z_base_scal(alpha, x) + class(psb_z_base_vect_type), intent(inout) :: x + complex(psb_dpk_), intent (in) :: alpha + integer(psb_ipk_) :: i + + if (allocated(x%v)) then +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i=1,size(x%v) + x%v(i) = alpha*x%v(i) + end do +#else + x%v = alpha*x%v +#endif + end if + call x%set_host() + end subroutine z_base_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_nrm2 + !! \memberof psb_z_base_vect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function z_base_nrm2(n,x) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + real(psb_dpk_), external :: dznrm2 + + if (x%is_dev()) call x%sync() + res = dznrm2(n,x%v,1) + + end function z_base_nrm2 + + ! + !> Function base_amax + !! \memberof psb_z_base_vect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function z_base_amax(n,x) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res = dzero + !$omp parallel do private(i) reduction(max: res) + do i=1, n + res = max(res,abs(x%v(i))) + end do +#else + res = maxval(abs(x%v(1:n))) +#endif + end function z_base_amax + + + ! + !> Function base_asum + !! \memberof psb_z_base_vect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function z_base_asum(n,x) result(res) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: i + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + res=dzero + !$omp parallel do private(i) reduction(+: res) + do i= 1, size(x%v) + res = res + abs(x%v(i)) + end do +#else + res = sum(abs(x%v(1:n))) +#endif + end function z_base_asum + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_z_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine z_base_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine z_base_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_z_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine z_base_gthzv_x(i,n,idx,x,y) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: y(:) + class(psb_z_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine z_base_gthzv_x + + + ! + ! New comm internals impl. + ! + module subroutine z_base_gthzbuf(i,n,idx,x) + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_z_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine z_base_gthzbuf + + ! + !> Function base_device_wait: + !! \memberof psb_z_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine z_base_device_wait() + + end subroutine z_base_device_wait + + + module function z_base_use_buffer() result(res) + logical :: res + + res = .true. + end function z_base_use_buffer + + module subroutine z_base_new_buffer(n,x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine z_base_new_buffer + + + module subroutine z_base_new_comid(n,x,info) + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine z_base_new_comid + + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_z_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine z_base_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine z_base_gthzv + + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_z_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine z_base_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine z_base_sctb + + + module subroutine z_base_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_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine z_base_sctb_x + + + module subroutine z_base_sctb_buf(i,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta + class(psb_z_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine z_base_sctb_buf + + + + ! + !> Function _base_addconst_a2 + !! \memberof psb_z_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine z_base_addconst_a2(x,b,z,info) + real(psb_dpk_), intent(in) :: b + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() +#if defined(PSB_OPENMP) + n = size(x) + !$omp parallel do private(i) + do i = 1, n + z%v(i) = x(i) + b + end do +#else + z%v = x + b +#endif + info = 0 + + end subroutine z_base_addconst_a2 + + ! + !> Function _base_addconst_v2 + !! \memberof psb_z_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + module subroutine z_base_addconst_v2(x,b,z,info) + class(psb_z_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: b + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine z_base_addconst_v2 + +end submodule psb_z_base_vect_impl + + +submodule (psb_z_base_multivect_mod) psb_z_base_multivect_impl + use psi_serial_mod + use psb_realloc_mod + use psb_string_mod + implicit none +contains + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_z_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + module subroutine z_base_mlv_bld_x(x,this) + complex(psb_dpk_), intent(in) :: this(:,:) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine z_base_mlv_bld_x + + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_z_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + module subroutine z_base_mlv_bld_n(x,m,n,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info,scratch=scratch) + + end subroutine z_base_mlv_bld_n + + + !> Function base_mlv_all: + !! \memberof psb_z_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + module subroutine z_base_mlv_all(m,n, x, info) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine z_base_mlv_all + + + !> Function base_mlv_mold: + !! \memberof psb_z_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + module subroutine z_base_mlv_mold(x, y, info) + class(psb_z_base_multivect_type), intent(in) :: x + class(psb_z_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_z_base_multivect_type :: y, stat=info) + + end subroutine z_base_mlv_mold + + + module subroutine z_base_mlv_reinit(x, info) + class(psb_z_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = zzero + call x%set_host() + call x%set_upd() + end if + + end subroutine z_base_mlv_reinit + + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_z_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + module subroutine z_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine z_base_mlv_ins + + + ! + !> Function base_mlv_zero + !! \memberof psb_z_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine z_base_mlv_zero(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=zzero + call x%set_host() + + end subroutine z_base_mlv_zero + + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_z_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + module subroutine z_base_mlv_asb(m,n, x, info, scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + complex(psb_dpk_), allocatable :: vv(:,:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(m,n,vv,info) + vv(:,:) = zzero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i),:) = x%v(i,:) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (any(vv(x%iv(i),:).ne.zzero)) then + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') + return + else + vv(x%iv(i),:) = x%v(i,:) + end if + end do + case default + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_z_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine z_base_mlv_free(x, info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine z_base_mlv_free + + + module function z_base_mlv_get_ncfs(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function z_base_mlv_get_ncfs + + module function z_base_mlv_get_dupl(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function z_base_mlv_get_dupl + + module function z_base_mlv_get_state(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function z_base_mlv_get_state + + module function z_base_mlv_is_null(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function z_base_mlv_is_null + + module function z_base_mlv_is_bld(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function z_base_mlv_is_bld + + module function z_base_mlv_is_upd(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function z_base_mlv_is_upd + + module function z_base_mlv_is_asb(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function z_base_mlv_is_asb + + module subroutine z_base_mlv_set_ncfs(n,x) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine z_base_mlv_set_ncfs + + + module subroutine z_base_mlv_set_dupl(n,x) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine z_base_mlv_set_dupl + + + module subroutine z_base_mlv_set_state(n,x) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine z_base_mlv_set_state + + + module subroutine z_base_mlv_set_null(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine z_base_mlv_set_null + + + module subroutine z_base_mlv_set_bld(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine z_base_mlv_set_bld + + + module subroutine z_base_mlv_set_upd(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine z_base_mlv_set_upd + + + module subroutine z_base_mlv_set_asb(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine z_base_mlv_set_asb + + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_z_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + module subroutine z_base_mlv_sync(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + end subroutine z_base_mlv_sync + + + ! + !> Function base_mlv_set_host: + !! \memberof psb_z_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + module subroutine z_base_mlv_set_host(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + end subroutine z_base_mlv_set_host + + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_z_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + module subroutine z_base_mlv_set_dev(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + end subroutine z_base_mlv_set_dev + + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_z_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + module subroutine z_base_mlv_set_sync(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + end subroutine z_base_mlv_set_sync + + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_z_base_multivect_type + !! \brief Is vector on external device . + !! + ! + module function z_base_mlv_is_dev(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function z_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_z_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + module function z_base_mlv_is_host(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function z_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_z_base_multivect_type + !! \brief Is vector on sync . + !! + ! + module function z_base_mlv_is_sync(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function z_base_mlv_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + module subroutine z_base_mlv_cpy(x, y) + class(psb_z_base_multivect_type), intent(in) :: x + class(psb_z_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine z_base_mlv_cpy + + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_z_base_multivect_type + !! \brief Number of entries + !! + ! + module function z_base_mlv_get_nrows(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function z_base_mlv_get_nrows + + module function z_base_mlv_get_ncols(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function z_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_z_base_multivect_type + !! \brief Size in bytesa + !! + ! + module function z_base_mlv_sizeof(x) result(res) + class(psb_z_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() * x%get_ncols() + + end function z_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_z_base_multivect_type + !! \brief Format + !! + ! + module function z_base_mlv_get_fmt() result(res) + character(len=5) :: res + res = 'BASE' + end function z_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_z_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + module function z_base_mlv_get_vect(x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function z_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_z_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + module subroutine z_base_mlv_set_scal(x,val) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine z_base_mlv_set_scal + + + ! + !> Function base_mlv_set_vect + !! \memberof psb_z_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + module subroutine z_base_mlv_set_vect(x,val) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine z_base_mlv_set_vect + + + ! + ! Dot products + ! + ! + !> Function base_mlv_dot_v + !! \memberof psb_z_base_multivect_type + !! \brief Dot product by another base_mlv_vector + !! \param n Number of entries to be considered + !! \param y The other (base_mlv_vect) to be multiplied by + !! + module function z_base_mlv_dot_v(n,x,y) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x, y + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_), allocatable :: res(:) + complex(psb_dpk_), external :: zdotc + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + res = zzero + ! + ! Note: this is the base implementation. + ! When we get here, we are sure that X is of + ! TYPE psb_z_base_mlv_vect (or its class does not care). + ! If Y is not, throw the burden on it, implicitly + ! calling dot_a + ! + select type(yy => y) + type is (psb_z_base_multivect_type) + if (y%is_dev()) call y%sync() + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = zdotc(n,x%v(:,j),1,y%v(:,j),1) + end do + class default + res = y%dot(n,x%v) + end select + + end function z_base_mlv_dot_v + + ! + ! Base workhorse is good old BLAS1 + ! + ! + !> Function base_mlv_dot_a + !! \memberof psb_z_base_multivect_type + !! \brief Dot product by a normal array + !! \param n Number of entries to be considered + !! \param y(:) The array to be multiplied by + !! + module function z_base_mlv_dot_a(n,x,y) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent(in) :: y(:,:) + integer(psb_ipk_), intent(in) :: n + complex(psb_dpk_), allocatable :: res(:) + complex(psb_dpk_), external :: zdotc + integer(psb_ipk_) :: j,nc + + if (x%is_dev()) call x%sync() + nc = min(psb_size(x%v,2_psb_ipk_),size(y,2_psb_ipk_)) + allocate(res(nc)) + do j=1,nc + res(j) = zdotc(n,x%v(:,j),1,y(:,j),1) + end do + + end function z_base_mlv_dot_a + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + ! + !> Function base_mlv_axpby_v + !! \memberof psb_z_base_multivect_type + !! \brief AXPBY by a (base_mlv_vect) y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_mlv_vect) to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine z_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + + if (present(n)) then + nc = n + else + nc = min(psb_size(x%v,2_psb_ipk_),psb_size(y%v,2_psb_ipk_)) + end if + select type(xx => x) + type is (psb_z_base_multivect_type) + call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) + class default + call y%axpby(m,alpha,x%v,beta,info,n=n) + end select + + end subroutine z_base_mlv_axpby_v + + + ! + ! AXPBY is invoked via Y, hence the structure below. + ! + ! + !> Function base_mlv_axpby_a + !! \memberof psb_z_base_multivect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar alpha + !! \param info return code + !! + module subroutine z_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:,:) + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: n + integer(psb_ipk_) :: nc + if (present(n)) then + nc = n + else + nc = min(size(x,2),psb_size(y%v,2_psb_ipk_)) + end if + + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) + + end subroutine z_base_mlv_axpby_a + + + + ! + ! Multiple variants of two operations: + ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) + ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:) + ! + ! Variants expanded according to the dynamic type + ! of the involved entities + ! + ! + !> Function base_mlv_mlt_mv + !! \memberof psb_z_base_multivect_type + !! \brief Multivector entry-by-entry multiply by a base_mlv_multivect y=x*y + !! \param x The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlv_mlt_mv(x, y, info) + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine z_base_mlv_mlt_mv + + + module subroutine z_base_mlv_mlt_mv_v(x, y, info) + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call y%mlt(x%v,info) + + end subroutine z_base_mlv_mlt_mv_v + + + ! + !> Function base_mlv_mlt_ar1 + !! \memberof psb_z_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 1 array y=x*y + !! \param x(:) The array to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlv_mlt_ar1(x, y, info) + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + n = min(psb_size(y%v,1_psb_ipk_), size(x)) + do i=1, n + y%v(i,:) = y%v(i,:)*x(i) + end do + + end subroutine z_base_mlv_mlt_ar1 + + + ! + !> Function base_mlv_mlt_ar2 + !! \memberof psb_z_base_multivect_type + !! \brief MultiVector entry-by-entry multiply by a rank 2 array y=x*y + !! \param x(:,:) The array to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlv_mlt_ar2(x, y, info) + complex(psb_dpk_), intent(in) :: x(:,:) + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr,nc + + info = 0 + nr = min(psb_size(y%v,1_psb_ipk_), size(x,1)) + nc = min(psb_size(y%v,2_psb_ipk_), size(x,2)) + y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) + + end subroutine z_base_mlv_mlt_ar2 + + + + ! + !> Function base_mlv_mlt_a_2 + !! \memberof psb_z_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x(:) The array to be multiplied b + !! \param y(:) The array to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlv_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_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, nr, nc + + info = 0 + nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == zzero) then + if (beta == zone) then + return + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + end if + else + if (alpha == zone) then + if (beta == zzero) then + z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == zone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else if (alpha == -zone) then + if (beta == zzero) then + z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == zone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) + end if + else + if (beta == zzero) then + z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else if (beta == zone) then + z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + else + z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) + end if + end if + end if + end subroutine z_base_mlv_mlt_a_2 + + + ! + !> Function base_mlv_mlt_v_2 + !! \memberof psb_z_base_multivect_type + !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_mlv_vect) + !! z=beta*z+alpha*x*y + !! \param alpha + !! \param beta + !! \param x The class(base_mlv_vect) to be multiplied b + !! \param y The class(base_mlv_vect) to be multiplied by + !! \param info return code + !! + module subroutine z_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) + complex(psb_dpk_), intent(in) :: alpha,beta + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_z_base_multivect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + integer(psb_ipk_) :: i, n + logical :: conjgx_, conjgy_ + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + if (z%is_dev()) call z%sync() + if (.not.psb_z_is_complex_) then + call z%mlt(alpha,x%v,y%v,beta,info) + else + conjgx_=.false. + if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') + conjgy_=.false. + if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C') + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + call z%mlt(alpha,x%v,y%v,beta,info) + if (conjgx_) x%v=conjg(x%v) + if (conjgy_) y%v=conjg(y%v) + end if + end subroutine z_base_mlv_mlt_v_2 + +!!$ +!!$ subroutine z_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ complex(psb_dpk_), intent(in) :: alpha,beta +!!$ complex(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_z_base_multivect_type), intent(inout) :: y +!!$ class(psb_z_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,x,y%v,beta,info) +!!$ +!!$ end subroutine z_base_mlv_mlt_av + +!!$ +!!$ subroutine z_base_mlv_mlt_va(alpha,x,y,beta,z,info) +!!$ complex(psb_dpk_), intent(in) :: alpha,beta +!!$ complex(psb_dpk_), intent(in) :: y(:) +!!$ class(psb_z_base_multivect_type), intent(inout) :: x +!!$ class(psb_z_base_multivect_type), intent(inout) :: z +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: i, n +!!$ +!!$ info = 0 +!!$ +!!$ call z%mlt(alpha,y,x,beta,info) +!!$ +!!$ end subroutine z_base_mlv_mlt_va + +!!$ +!!$ + ! + ! Simple scaling + ! + !> Function base_mlv_scal + !! \memberof psb_z_base_multivect_type + !! \brief Scale all entries x = alpha*x + !! \param alpha The multiplier + !! +module subroutine z_base_mlv_scal(alpha, x) + class(psb_z_base_multivect_type), intent(inout) :: x + complex(psb_dpk_), intent (in) :: alpha + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) x%v = alpha*x%v + + end subroutine z_base_mlv_scal + + + ! + ! Norms 1, 2 and infinity + ! + !> Function base_mlv_nrm2 + !! \memberof psb_z_base_multivect_type + !! \brief 2-norm |x(1:n)|_2 + !! \param n how many entries to consider + module function z_base_mlv_nrm2(n,x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + real(psb_dpk_), external :: dznrm2 + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = dznrm2(n,x%v(:,j),1) + end do + + end function z_base_mlv_nrm2 + + + ! + !> Function base_mlv_amax + !! \memberof psb_z_base_multivect_type + !! \brief infinity-norm |x(1:n)|_\infty + !! \param n how many entries to consider + module function z_base_mlv_amax(n,x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = maxval(abs(x%v(1:n,j))) + end do + + end function z_base_mlv_amax + + + ! + !> Function base_mlv_asum + !! \memberof psb_z_base_multivect_type + !! \brief 1-norm |x(1:n)|_1 + !! \param n how many entries to consider + module function z_base_mlv_asum(n,x) result(res) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_), allocatable :: res(:) + integer(psb_ipk_) :: j, nc + + if (x%is_dev()) call x%sync() + nc = psb_size(x%v,2_psb_ipk_) + allocate(res(nc)) + do j=1,nc + res(j) = sum(abs(x%v(1:n,j))) + end do + + end function z_base_mlv_asum + + ! + ! Overwrite with absolute value + ! + ! + !> Function base_absval1 + !! \memberof psb_z_base_vect_type + !! \brief Set all entries to their respective absolute values. + !! + module subroutine z_base_mlv_absval1(x) + class(psb_z_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v = abs(x%v) + call x%set_host() + end if + + end subroutine z_base_mlv_absval1 + + + module subroutine z_base_mlv_absval2(x,y) + class(psb_z_base_multivect_type), intent(inout) :: x + class(psb_z_base_multivect_type), intent(inout) :: y + integer(psb_ipk_) :: info + + if (x%is_dev()) call x%sync() + if (allocated(x%v)) then + call y%axpby(min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) + call y%absval() + end if + + end subroutine z_base_mlv_absval2 + + + + module function z_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function z_base_mlv_use_buffer + + + module subroutine z_base_mlv_new_buffer(n,x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine z_base_mlv_new_buffer + + + module subroutine z_base_mlv_new_comid(n,x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine z_base_mlv_new_comid + + + + module subroutine z_base_mlv_maybe_free_buffer(x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine z_base_mlv_maybe_free_buffer + + + module subroutine z_base_mlv_free_buffer(x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine z_base_mlv_free_buffer + + + module subroutine z_base_mlv_free_comid(x,info) + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine z_base_mlv_free_comid + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_z_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + module subroutine z_base_mlv_gthab(n,idx,alpha,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine z_base_mlv_gthab + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_z_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine z_base_mlv_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_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine z_base_mlv_gthzv_x + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_z_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine z_base_mlv_gthzv(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine z_base_mlv_gthzv + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_z_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + module subroutine z_base_mlv_gthzm(n,idx,x,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: y(:,:) + class(psb_z_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine z_base_mlv_gthzm + + + ! + ! New comm internals impl. + ! + module subroutine z_base_mlv_gthzbuf(i,ixb,n,idx,x) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_z_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine z_base_mlv_gthzbuf + + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_z_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + module subroutine z_base_mlv_sctb(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine z_base_mlv_sctb + + + module subroutine z_base_mlv_sctbr2(n,idx,x,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + complex(psb_dpk_) :: beta, x(:,:) + class(psb_z_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine z_base_mlv_sctbr2 + + + module subroutine z_base_mlv_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_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine z_base_mlv_sctb_x + + + module subroutine z_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta + class(psb_z_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine z_base_mlv_sctb_buf + + + ! + !> Function base_device_wait: + !! \memberof psb_z_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + module subroutine z_base_mlv_device_wait() + + end subroutine z_base_mlv_device_wait + +end submodule psb_z_base_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 000000000..4f4461a08 --- /dev/null +++ b/base/serial/impl/psb_z_vect_impl.F90 @@ -0,0 +1,1629 @@ +! +! 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 psb_base_mod + use psi_serial_mod + implicit none + +contains + + module function z_vect_get_dupl(x) result(res) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + + 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) + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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%div(x%v,info) + + end subroutine z_vect_div_v + + 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 + 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) + 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%div(x%v,info,flag) + + end subroutine z_vect_div_v_check + + 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 + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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 psb_base_mod + use psi_serial_mod + +contains + + module function z_mvect_get_dupl(x) result(res) + 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) + 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) + 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) + 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 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 + + 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) + 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) + 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) + 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) + 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) + + 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) + + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) + 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) +!!$ 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 +!!$ +!!$ function z_mvect_dot_a(n,x,y) result(res) +!!$ 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) +!!$ 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 +!!$ +!!$ subroutine z_mvect_axpby_a(m,alpha, x, beta, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine z_mvect_mlt_v(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 +!!$ 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 +!!$ +!!$ subroutine z_mvect_mlt_a(x, y, info) +!!$ 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 +!!$ +!!$ +!!$ subroutine z_mvect_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_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 +!!$ +!!$ subroutine z_mvect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) +!!$ 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 +!!$ +!!$ subroutine z_mvect_mlt_av(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine z_mvect_mlt_va(alpha,x,y,beta,z,info) +!!$ 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 +!!$ +!!$ subroutine z_mvect_scal(alpha, x) +!!$ 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 +!!$ +!!$ +!!$ function z_mvect_nrm2(n,x) result(res) +!!$ 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 +!!$ +!!$ function z_mvect_amax(n,x) result(res) +!!$ 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 +!!$ +!!$ function z_mvect_asum(n,x) result(res) +!!$ 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