diff --git a/CMakeLists.txt b/CMakeLists.txt index 90685757..84eed7b3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -428,7 +428,7 @@ if(METIS_FOUND) include(CheckTypeSize) message(STATUS "METIS PATH ${METIS_INCLUDES} and metis libraries ${METIS_LIBRARIES}") # Make sure this path is correct -# set(METISINCFILE "metis.h") # Adjust this to your actual path + set(CMAKE_METIS_INCFILE "metis.h") # Adjust this to your actual path # Specify the configuration file # set(HEADER_TEMPLATE "${CMAKE_CURRENT_SOURCE_DIR}/util/psb_metis_int.h.in") @@ -509,7 +509,7 @@ if(METIS_FOUND) # 1. Tell CMake where to find metis.h for the check -set(CMAKE_EXTRA_INCLUDE_FILES "${METIS_INCLUDES}/metis.h") +set(CMAKE_EXTRA_INCLUDE_FILES "${METIS_INCLUDES}/${CMAKE_METIS_INCFILE}") # 2. Check the size of Metis's own type: real_t # This replaces checking 'float' and 'double' separately diff --git a/ReleaseNews b/ReleaseNews index cf60dc52..4df65c99 100644 --- a/ReleaseNews +++ b/ReleaseNews @@ -1,4 +1,8 @@ WHAT'S NEW +Version 3.9.0-1 + 1. Fix licensing issues + 2. Fix build and packaging + Version 3.9 1. PSBLAS3-EXT has been folded into the main library 2. Renamed GPU into CUDA. diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 5fcf9cbb..73344958 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -281,6 +281,12 @@ set(PSB_base_source_files serial/psb_dnumbmm.f90 serial/psb_damax_s.f90 serial/psb_zgeprt.f90 + serial/impl/psb_i_base_vect_impl.F90 + serial/impl/psb_l_base_vect_impl.F90 + serial/impl/psb_c_base_vect_impl.F90 + serial/impl/psb_z_base_vect_impl.F90 + serial/impl/psb_s_base_vect_impl.F90 + serial/impl/psb_d_base_vect_impl.F90 serial/impl/psb_c_coo_impl.F90 serial/impl/psb_d_coo_impl.F90 serial/impl/psb_d_csc_impl.F90 @@ -460,6 +466,7 @@ set(PSB_base_source_files modules/comm/psb_d_comm_mod.f90 modules/comm/psi_e_comm_a_mod.f90 modules/comm/psb_c_comm_a_mod.f90 + modules/comm/psi_i2_comm_a_mod.f90 modules/comm/psb_linmap_mod.f90 modules/comm/psb_z_comm_a_mod.f90 modules/comm/psi_c_comm_a_mod.f90 diff --git a/base/modules/psi_i2_mod.F90 b/base/modules/psi_i2_mod.F90 index 031bcf20..f918bc77 100644 --- a/base/modules/psi_i2_mod.F90 +++ b/base/modules/psi_i2_mod.F90 @@ -31,7 +31,7 @@ ! module psi_i2_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & & psb_lpk_, psb_i2pk_ use psi_m_comm_a_mod use psi_e_comm_a_mod diff --git a/base/modules/psi_i_mod.F90 b/base/modules/psi_i_mod.F90 index 22df3462..aa44e9ff 100644 --- a/base/modules/psi_i_mod.F90 +++ b/base/modules/psi_i_mod.F90 @@ -31,7 +31,7 @@ ! module psi_i_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & & psb_lpk_, psb_i2pk_ use psi_m_comm_a_mod use psi_e_comm_a_mod diff --git a/base/modules/psi_l_mod.F90 b/base/modules/psi_l_mod.F90 index 6be25a13..c1e38189 100644 --- a/base/modules/psi_l_mod.F90 +++ b/base/modules/psi_l_mod.F90 @@ -31,7 +31,7 @@ ! module psi_l_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & & psb_lpk_, psb_i2pk_ use psi_m_comm_a_mod use psi_e_comm_a_mod diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index cd970162..9ed92cb1 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_c_base_vect_mod procedure, pass(x) :: set_vect => c_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> c_base_get_entry + procedure, pass(x) :: set_entry=> c_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -250,8 +251,6 @@ module psb_c_base_vect_mod module procedure constructor, size_const end interface psb_c_base_vect -contains - ! ! Constructors. ! @@ -260,30 +259,31 @@ contains !! \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 + interface + module 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 + end function constructor + end interface !> 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 + interface + module function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_c_base_vect_type) :: this + integer(psb_ipk_) :: info + + end function size_const + end interface ! + ! Build from a sample ! @@ -292,36 +292,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 @@ -332,50 +309,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 @@ -384,21 +337,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 @@ -406,43 +351,22 @@ 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. ! @@ -470,153 +394,25 @@ 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 ! !> Function base_zero @@ -624,18 +420,11 @@ 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 - - if (allocated(x%v)) then - !$omp workshare - x%v(:)=czero - !$omp end workshare - end if - call x%set_host() - end subroutine c_base_zero + interface + module subroutine c_base_zero(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_zero + end interface ! @@ -651,75 +440,14 @@ contains !! \param info return code !! ! - - 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. @@ -734,75 +462,14 @@ contains !! \param info return code !! ! - - 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: @@ -812,22 +479,12 @@ 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 - - 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 + 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 ! !> Function base_free_buffer: @@ -837,15 +494,12 @@ 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 - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine c_base_free_buffer + 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 ! !> Function base_maybe_free_buffer: @@ -858,17 +512,12 @@ 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) - - end subroutine c_base_maybe_free_buffer + 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 ! !> Function base_free_comid: @@ -878,113 +527,106 @@ 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 + 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 - 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 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 @@ -996,11 +638,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: @@ -1008,11 +650,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: @@ -1020,11 +662,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: @@ -1032,11 +674,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: @@ -1044,13 +686,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 @@ -1058,13 +699,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 @@ -1072,32 +712,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. @@ -1108,15 +740,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 @@ -1124,15 +753,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 @@ -1140,12 +766,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 ! ! @@ -1155,33 +780,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_) :: info + integer(psb_ipk_), optional :: n + end function c_base_get_vect + end interface ! ! Reset all values @@ -1192,32 +798,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 @@ -1225,43 +812,19 @@ 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 + 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 - write(0,*) 'Check addr: base version, do nothing' - - end subroutine c_base_check_addr + 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 ! @@ -1273,16 +836,21 @@ 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(in) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_spk_) :: res - - res = 0 - if (allocated(x%v)) res = x%v(index) - - end function c_base_get_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 @@ -1292,39 +860,18 @@ 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 + interface + module subroutine c_base_absval1(x) + class(psb_c_base_vect_type), intent(inout) :: x + end subroutine c_base_absval1 + end interface - 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_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 @@ -1336,30 +883,14 @@ 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 c_base_dot_v + end interface + ! ! Base workhorse is good old BLAS1 ! @@ -1370,17 +901,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. @@ -1396,20 +924,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. @@ -1427,21 +950,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. @@ -1456,20 +974,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. @@ -1485,21 +998,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. @@ -1518,47 +1026,28 @@ 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: @@ -1575,19 +1064,13 @@ 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 @@ -1596,25 +1079,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 @@ -1627,87 +1098,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 @@ -1719,68 +1119,36 @@ 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 @@ -1788,19 +1156,13 @@ 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 x%div(x%v,y%v,info) - - end subroutine c_base_div_v + 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 ! !> Function base_div_v2 !! \memberof psb_c_base_vect_type @@ -1808,21 +1170,14 @@ 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 (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info) - - - 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 @@ -1830,20 +1185,14 @@ 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() - 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 @@ -1851,21 +1200,15 @@ 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 @@ -1873,25 +1216,14 @@ 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 @@ -1900,35 +1232,15 @@ 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 @@ -1936,20 +1248,13 @@ 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 @@ -1958,20 +1263,14 @@ 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 + logical, intent(in) :: flag + end subroutine c_base_inv_v_check + end interface ! !> Function base_inv_a2 !! \memberof psb_c_base_vect_type @@ -1980,24 +1279,13 @@ 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 @@ -2007,35 +1295,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 @@ -2046,29 +1313,14 @@ 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 @@ -2078,19 +1330,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 ! @@ -2099,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 @@ -2126,41 +1360,26 @@ 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 ! @@ -2168,24 +1387,13 @@ contains !! \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 ! @@ -2200,18 +1408,14 @@ 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 ! @@ -2221,77 +1425,59 @@ 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 @@ -2302,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: @@ -2328,55 +1510,34 @@ 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 ! @@ -2388,28 +1549,14 @@ 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 @@ -2419,18 +1566,14 @@ 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 end module psb_c_base_vect_mod @@ -2602,8 +1745,6 @@ module psb_c_base_multivect_mod module procedure constructor, size_const end interface psb_c_base_multivect -contains - ! ! Constructors. ! @@ -2612,29 +1753,23 @@ contains !! \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 - - + interface + module function constructor(x) result(this) + complex(psb_spk_) :: x(:,:) + type(psb_c_base_multivect_type) :: this + end function constructor + end interface + !> 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 + interface + module function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_c_base_multivect_type) :: this + end function size_const + end interface ! ! Build from a sample @@ -2645,20 +1780,12 @@ 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 + end subroutine c_base_mlv_bld_x + end interface ! ! Create with size, but no initialization @@ -2669,17 +1796,13 @@ 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 + logical, intent(in), optional :: scratch + end subroutine c_base_mlv_bld_n + end interface !> Function base_mlv_all: !! \memberof psb_c_base_multivect_type @@ -2688,21 +1811,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 @@ -2710,34 +1825,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 + 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 - 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 - - 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. @@ -2766,129 +1867,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 @@ -2896,16 +1883,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. @@ -2920,81 +1902,14 @@ 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: @@ -3004,118 +1919,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 @@ -3127,11 +2030,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: @@ -3139,11 +2042,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: @@ -3151,11 +2054,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: @@ -3163,11 +2066,12 @@ 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) + implicit none + class(psb_c_base_multivect_type), intent(inout) :: x + end subroutine c_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3175,13 +2079,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 @@ -3189,13 +2092,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 @@ -3203,34 +2105,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. ! @@ -3240,25 +2133,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 - - 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) + 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 - 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 @@ -3266,15 +2153,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 @@ -3282,13 +2166,12 @@ 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 + ! ! ! @@ -3297,22 +2180,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 @@ -3323,15 +2196,13 @@ 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) + implicit none + 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 @@ -3339,23 +2210,12 @@ contains !! \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 @@ -3367,36 +2227,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 @@ -3408,23 +2245,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. @@ -3440,30 +2268,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. @@ -3478,26 +2292,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: @@ -3514,31 +2318,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) - - end subroutine c_base_mlv_mlt_mv + 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 - 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 @@ -3547,21 +2341,13 @@ 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 @@ -3570,21 +2356,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 @@ -3597,53 +2375,15 @@ 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 @@ -3656,40 +2396,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(:) @@ -3705,7 +2423,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(:) @@ -3729,16 +2446,12 @@ 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 @@ -3747,64 +2460,39 @@ 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 + 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 ! @@ -3813,96 +2501,62 @@ 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 + 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(:)) @@ -3916,23 +2570,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 ! @@ -3942,19 +2587,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 @@ -3965,24 +2606,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 ! @@ -3992,47 +2623,26 @@ 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: @@ -4047,72 +2657,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: @@ -4120,9 +2701,9 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine c_base_mlv_device_wait() - implicit none - - end subroutine c_base_mlv_device_wait + interface + module subroutine c_base_mlv_device_wait() + end subroutine c_base_mlv_device_wait + end interface 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 b418a30e..7ccf322c 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_c_vect_mod procedure, pass(x) :: check_addr => c_vect_check_addr procedure, pass(x) :: get_entry => c_vect_get_entry + procedure, pass(x) :: set_entry => c_vect_set_entry procedure, pass(x) :: dot_v => c_vect_dot_v procedure, pass(x) :: dot_a => c_vect_dot_a @@ -855,13 +856,22 @@ contains function c_vect_get_entry(x,index) result(res) implicit none - class(psb_c_vect_type), intent(in) :: x + class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_spk_) :: res - res = 0 + 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 diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index fa2c4866..9145a9d5 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_d_base_vect_mod procedure, pass(x) :: set_vect => d_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> d_base_get_entry + procedure, pass(x) :: set_entry=> d_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -257,8 +258,6 @@ module psb_d_base_vect_mod module procedure constructor, size_const end interface psb_d_base_vect -contains - ! ! Constructors. ! @@ -267,30 +266,31 @@ contains !! \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 + interface + module 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 + end function constructor + end interface !> 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 + interface + module function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_d_base_vect_type) :: this + integer(psb_ipk_) :: info + + end function size_const + end interface ! + ! Build from a sample ! @@ -299,36 +299,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 @@ -339,50 +316,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 @@ -391,21 +344,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 @@ -413,43 +358,22 @@ 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. ! @@ -477,153 +401,25 @@ 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 ! !> Function base_zero @@ -631,18 +427,11 @@ 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 - - if (allocated(x%v)) then - !$omp workshare - x%v(:)=dzero - !$omp end workshare - end if - call x%set_host() - end subroutine d_base_zero + interface + module subroutine d_base_zero(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_zero + end interface ! @@ -658,75 +447,14 @@ contains !! \param info return code !! ! - - 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. @@ -741,75 +469,14 @@ contains !! \param info return code !! ! - - 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: @@ -819,22 +486,12 @@ 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 - - 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 + 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 ! !> Function base_free_buffer: @@ -844,15 +501,12 @@ 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 - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine d_base_free_buffer + 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 ! !> Function base_maybe_free_buffer: @@ -865,17 +519,12 @@ 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 - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine d_base_maybe_free_buffer + 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 ! !> Function base_free_comid: @@ -885,113 +534,106 @@ 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 + 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 - 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 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 @@ -1003,11 +645,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: @@ -1015,11 +657,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: @@ -1027,11 +669,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: @@ -1039,11 +681,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: @@ -1051,13 +693,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 @@ -1065,13 +706,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 @@ -1079,32 +719,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. @@ -1115,15 +747,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 @@ -1131,15 +760,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 @@ -1147,12 +773,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 ! ! @@ -1162,33 +787,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_) :: info + integer(psb_ipk_), optional :: n + end function d_base_get_vect + end interface ! ! Reset all values @@ -1199,32 +805,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 @@ -1232,43 +819,19 @@ 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 + 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 - 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_check_addr(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_check_addr + end interface ! @@ -1280,16 +843,21 @@ 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(in) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_dpk_) :: res - - res = 0 - if (allocated(x%v)) res = x%v(index) - - end function d_base_get_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 @@ -1299,39 +867,18 @@ 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 + interface + module subroutine d_base_absval1(x) + class(psb_d_base_vect_type), intent(inout) :: x + end subroutine d_base_absval1 + end interface - 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_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 @@ -1343,30 +890,14 @@ 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 d_base_dot_v + end interface + ! ! Base workhorse is good old BLAS1 ! @@ -1377,17 +908,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. @@ -1403,20 +931,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. @@ -1434,21 +957,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. @@ -1463,20 +981,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. @@ -1492,21 +1005,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. @@ -1525,47 +1033,28 @@ 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: @@ -1582,19 +1071,13 @@ 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 @@ -1603,25 +1086,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 @@ -1634,87 +1105,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 @@ -1726,68 +1126,36 @@ 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 @@ -1795,19 +1163,13 @@ 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 x%div(x%v,y%v,info) - - end subroutine d_base_div_v + 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 ! !> Function base_div_v2 !! \memberof psb_d_base_vect_type @@ -1815,21 +1177,14 @@ 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 (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info) - - - 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 @@ -1837,20 +1192,14 @@ 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() - 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 @@ -1858,21 +1207,15 @@ 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 @@ -1880,25 +1223,14 @@ 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 @@ -1907,35 +1239,15 @@ 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 @@ -1943,20 +1255,13 @@ 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 @@ -1965,20 +1270,14 @@ 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 + logical, intent(in) :: flag + end subroutine d_base_inv_v_check + end interface ! !> Function base_inv_a2 !! \memberof psb_d_base_vect_type @@ -1987,24 +1286,13 @@ 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 @@ -2014,35 +1302,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 @@ -2053,29 +1320,14 @@ 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 @@ -2085,19 +1337,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 ! @@ -2106,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 @@ -2133,70 +1367,40 @@ 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: 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 !! \memberof psb_d_base_vect_type @@ -2205,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 @@ -2229,29 +1426,14 @@ 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 ! @@ -2259,24 +1441,13 @@ contains !! \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 ! @@ -2291,18 +1462,14 @@ 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 ! @@ -2312,77 +1479,59 @@ 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 @@ -2393,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: @@ -2419,55 +1564,34 @@ 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 @@ -2482,56 +1606,15 @@ 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 @@ -2545,21 +1628,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 ! @@ -2571,28 +1648,14 @@ 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 @@ -2602,18 +1665,14 @@ 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 end module psb_d_base_vect_mod @@ -2785,8 +1844,6 @@ module psb_d_base_multivect_mod module procedure constructor, size_const end interface psb_d_base_multivect -contains - ! ! Constructors. ! @@ -2795,29 +1852,23 @@ contains !! \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 - - + interface + module function constructor(x) result(this) + real(psb_dpk_) :: x(:,:) + type(psb_d_base_multivect_type) :: this + end function constructor + end interface + !> 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 + interface + module function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_d_base_multivect_type) :: this + end function size_const + end interface ! ! Build from a sample @@ -2828,20 +1879,12 @@ 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 + end subroutine d_base_mlv_bld_x + end interface ! ! Create with size, but no initialization @@ -2852,17 +1895,13 @@ 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 + logical, intent(in), optional :: scratch + end subroutine d_base_mlv_bld_n + end interface !> Function base_mlv_all: !! \memberof psb_d_base_multivect_type @@ -2871,21 +1910,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 @@ -2893,34 +1924,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) - - end subroutine d_base_mlv_mold + 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 - 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. @@ -2949,129 +1966,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 @@ -3079,16 +1982,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. @@ -3103,81 +2001,14 @@ 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: @@ -3187,118 +2018,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 @@ -3310,11 +2129,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: @@ -3322,11 +2141,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: @@ -3334,11 +2153,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: @@ -3346,11 +2165,12 @@ 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) + implicit none + class(psb_d_base_multivect_type), intent(inout) :: x + end subroutine d_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3358,13 +2178,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 @@ -3372,13 +2191,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 @@ -3386,34 +2204,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. ! @@ -3423,25 +2232,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 + 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 - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function d_base_mlv_get_nrows - - 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 @@ -3449,15 +2252,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 @@ -3465,13 +2265,12 @@ 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 + ! ! ! @@ -3480,22 +2279,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 @@ -3506,15 +2295,13 @@ 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) + implicit none + 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 @@ -3522,23 +2309,12 @@ contains !! \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 @@ -3550,36 +2326,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 @@ -3591,23 +2344,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. @@ -3623,30 +2367,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. @@ -3661,26 +2391,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: @@ -3697,31 +2417,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 + 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 - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine d_base_mlv_mlt_mv - - 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 @@ -3730,21 +2440,13 @@ 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 @@ -3753,21 +2455,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 @@ -3780,53 +2474,15 @@ 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 @@ -3839,40 +2495,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(:) @@ -3888,7 +2522,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(:) @@ -3912,16 +2545,12 @@ 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 @@ -3930,64 +2559,39 @@ 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 + 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 ! @@ -3996,96 +2600,62 @@ 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 + 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(:)) @@ -4099,23 +2669,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 ! @@ -4125,19 +2686,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 @@ -4148,24 +2705,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 ! @@ -4175,47 +2722,26 @@ 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: @@ -4230,72 +2756,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: @@ -4303,9 +2800,9 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine d_base_mlv_device_wait() - implicit none - - end subroutine d_base_mlv_device_wait + interface + module subroutine d_base_mlv_device_wait() + end subroutine d_base_mlv_device_wait + end interface 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 57d66d5b..0fa7441d 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_d_vect_mod procedure, pass(x) :: check_addr => d_vect_check_addr procedure, pass(x) :: get_entry => d_vect_get_entry + procedure, pass(x) :: set_entry => d_vect_set_entry procedure, pass(x) :: dot_v => d_vect_dot_v procedure, pass(x) :: dot_a => d_vect_dot_a @@ -862,13 +863,22 @@ contains function d_vect_get_entry(x,index) result(res) implicit none - class(psb_d_vect_type), intent(in) :: x + class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res - res = 0 + 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 @@ -1430,7 +1440,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = dzero + res = HUGE(dzero) end if end function d_vect_min diff --git a/base/modules/serial/psb_i2_base_vect_mod.F90 b/base/modules/serial/psb_i2_base_vect_mod.F90 index b90db989..7b1bb537 100644 --- a/base/modules/serial/psb_i2_base_vect_mod.F90 +++ b/base/modules/serial/psb_i2_base_vect_mod.F90 @@ -184,8 +184,6 @@ module psb_i2_base_vect_mod module procedure constructor, size_const end interface psb_i2_base_vect -contains - ! ! Constructors. ! @@ -194,30 +192,31 @@ contains !! \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 + interface + module 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 + end function constructor + end interface !> 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 + interface + module function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_i2_base_vect_type) :: this + integer(psb_ipk_) :: info + + end function size_const + end interface ! + ! Build from a sample ! @@ -226,36 +225,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 +242,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 +270,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,43 +284,22 @@ 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 - - end subroutine i2_base_reinit - + 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 + + 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,153 +327,25 @@ 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 ! !> Function base_zero @@ -558,18 +353,11 @@ 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 - - if (allocated(x%v)) then - !$omp workshare - x%v(:)=i2zero - !$omp end workshare - end if - call x%set_host() - end subroutine i2_base_zero + interface + module subroutine i2_base_zero(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_zero + end interface ! @@ -585,75 +373,14 @@ contains !! \param info return code !! ! - - 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. @@ -668,75 +395,14 @@ contains !! \param info return code !! ! - - 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 +412,12 @@ 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 - - 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 + 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 ! !> Function base_free_buffer: @@ -771,15 +427,12 @@ 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 - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine i2_base_free_buffer + 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 ! !> Function base_maybe_free_buffer: @@ -792,17 +445,12 @@ 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 - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine i2_base_maybe_free_buffer + 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 ! !> Function base_free_comid: @@ -812,113 +460,106 @@ 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 + 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 - 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 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 +571,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 +583,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 +595,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 +607,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 +619,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 +632,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 +645,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 +673,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 +686,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 +699,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,33 +713,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_) :: info + integer(psb_ipk_), optional :: n + end function i2_base_get_vect + end interface ! ! Reset all values @@ -1126,32 +731,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,43 +745,19 @@ 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 + 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 - 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_check_addr(x) + class(psb_i2_base_vect_type), intent(inout) :: x + end subroutine i2_base_check_addr + end interface @@ -1211,18 +773,14 @@ 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 +790,59 @@ 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 +853,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,55 +875,34 @@ 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 end module psb_i2_base_vect_mod @@ -1528,8 +1043,6 @@ module psb_i2_base_multivect_mod module procedure constructor, size_const end interface psb_i2_base_multivect -contains - ! ! Constructors. ! @@ -1538,29 +1051,23 @@ contains !! \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 - - + interface + module function constructor(x) result(this) + integer(psb_i2pk_) :: x(:,:) + type(psb_i2_base_multivect_type) :: this + end function constructor + end interface + !> 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 + interface + module function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_i2_base_multivect_type) :: this + end function size_const + end interface ! ! Build from a sample @@ -1571,20 +1078,12 @@ 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 + end subroutine i2_base_mlv_bld_x + end interface ! ! Create with size, but no initialization @@ -1595,17 +1094,13 @@ 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 + logical, intent(in), optional :: scratch + end subroutine i2_base_mlv_bld_n + end interface !> Function base_mlv_all: !! \memberof psb_i2_base_multivect_type @@ -1614,21 +1109,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 +1123,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) + 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 - 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 - - 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 +1165,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 +1181,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 +1200,14 @@ 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 +1217,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 +1328,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 +1340,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 +1352,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 +1364,12 @@ 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) + implicit none + 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 +1377,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 +1390,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,34 +1403,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 +1431,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) + 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 - end function i2_base_mlv_get_nrows - - 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 +1451,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,13 +1464,12 @@ 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 +1478,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,15 +1494,13 @@ 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) + implicit none + 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 @@ -2265,88 +1508,56 @@ contains !! \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 - - 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 + 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 - 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 +1571,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 +1588,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 +1607,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,47 +1624,26 @@ 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: @@ -2491,72 +1658,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 +1702,9 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine i2_base_mlv_device_wait() - implicit none - - end subroutine i2_base_mlv_device_wait + interface + module subroutine i2_base_mlv_device_wait() + end subroutine i2_base_mlv_device_wait + end interface end module psb_i2_base_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 31cd5f92..b6c1114b 100644 --- a/base/modules/serial/psb_i_base_vect_mod.F90 +++ b/base/modules/serial/psb_i_base_vect_mod.F90 @@ -183,8 +183,6 @@ module psb_i_base_vect_mod module procedure constructor, size_const end interface psb_i_base_vect -contains - ! ! Constructors. ! @@ -193,30 +191,31 @@ contains !! \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 + interface + module 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 + end function constructor + end interface !> 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 + interface + module function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_i_base_vect_type) :: this + integer(psb_ipk_) :: info + + end function size_const + end interface ! + ! Build from a sample ! @@ -225,36 +224,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 +241,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 +269,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,43 +283,22 @@ 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 - - end subroutine i_base_reinit - + 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 + + 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,153 +326,25 @@ 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 ! !> Function base_zero @@ -557,18 +352,11 @@ 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 - - if (allocated(x%v)) then - !$omp workshare - x%v(:)=izero - !$omp end workshare - end if - call x%set_host() - end subroutine i_base_zero + interface + module subroutine i_base_zero(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_zero + end interface ! @@ -584,75 +372,14 @@ contains !! \param info return code !! ! - - 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. @@ -667,75 +394,14 @@ contains !! \param info return code !! ! - - 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 +411,12 @@ 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 - - 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 + 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 ! !> Function base_free_buffer: @@ -770,15 +426,12 @@ 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 - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine i_base_free_buffer + 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 ! !> Function base_maybe_free_buffer: @@ -791,17 +444,12 @@ 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 - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine i_base_maybe_free_buffer + 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 ! !> Function base_free_comid: @@ -811,113 +459,106 @@ 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 + 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 - 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 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 +570,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 +582,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 +594,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 +606,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 +618,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 +631,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 +644,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 +672,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 +685,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 +698,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,33 +712,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_) :: info + integer(psb_ipk_), optional :: n + end function i_base_get_vect + end interface ! ! Reset all values @@ -1125,32 +730,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,43 +744,19 @@ 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 + 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 - 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_check_addr(x) + class(psb_i_base_vect_type), intent(inout) :: x + end subroutine i_base_check_addr + end interface @@ -1210,18 +772,14 @@ 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 +789,59 @@ 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 +852,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,55 +874,34 @@ 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 end module psb_i_base_vect_mod @@ -1527,8 +1042,6 @@ module psb_i_base_multivect_mod module procedure constructor, size_const end interface psb_i_base_multivect -contains - ! ! Constructors. ! @@ -1537,29 +1050,23 @@ contains !! \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 - - + interface + module function constructor(x) result(this) + integer(psb_ipk_) :: x(:,:) + type(psb_i_base_multivect_type) :: this + end function constructor + end interface + !> 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 + interface + module function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_i_base_multivect_type) :: this + end function size_const + end interface ! ! Build from a sample @@ -1570,20 +1077,12 @@ 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 + end subroutine i_base_mlv_bld_x + end interface ! ! Create with size, but no initialization @@ -1594,17 +1093,13 @@ 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 + logical, intent(in), optional :: scratch + end subroutine i_base_mlv_bld_n + end interface !> Function base_mlv_all: !! \memberof psb_i_base_multivect_type @@ -1613,21 +1108,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 +1122,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) + 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 - 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 - - 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 +1164,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 +1180,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 +1199,14 @@ 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 +1216,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 +1327,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 +1339,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 +1351,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 +1363,12 @@ 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) + implicit none + 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 +1376,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 +1389,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,34 +1402,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 +1430,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) + 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 - end function i_base_mlv_get_nrows - - 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 +1450,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,13 +1463,12 @@ 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 +1477,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,15 +1493,13 @@ 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) + implicit none + 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 @@ -2264,88 +1507,56 @@ contains !! \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 - - 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 + 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 - 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 +1570,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 +1587,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 +1606,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,47 +1623,26 @@ 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: @@ -2490,72 +1657,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 +1701,9 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine i_base_mlv_device_wait() - implicit none - - end subroutine i_base_mlv_device_wait + interface + module subroutine i_base_mlv_device_wait() + end subroutine i_base_mlv_device_wait + end interface end module psb_i_base_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 5be178a5..9af9b072 100644 --- a/base/modules/serial/psb_l_base_vect_mod.F90 +++ b/base/modules/serial/psb_l_base_vect_mod.F90 @@ -184,8 +184,6 @@ module psb_l_base_vect_mod module procedure constructor, size_const end interface psb_l_base_vect -contains - ! ! Constructors. ! @@ -194,30 +192,31 @@ contains !! \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 + interface + module 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 + end function constructor + end interface !> 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 + interface + module function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_l_base_vect_type) :: this + integer(psb_ipk_) :: info + + end function size_const + end interface ! + ! Build from a sample ! @@ -226,36 +225,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 +242,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 +270,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,43 +284,22 @@ 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 - - end subroutine l_base_reinit - + 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 + + 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,153 +327,25 @@ 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 ! !> Function base_zero @@ -558,18 +353,11 @@ 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 - - if (allocated(x%v)) then - !$omp workshare - x%v(:)=lzero - !$omp end workshare - end if - call x%set_host() - end subroutine l_base_zero + interface + module subroutine l_base_zero(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_zero + end interface ! @@ -585,75 +373,14 @@ contains !! \param info return code !! ! - - 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. @@ -668,75 +395,14 @@ contains !! \param info return code !! ! - - 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 +412,12 @@ 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 - - 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 + 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 ! !> Function base_free_buffer: @@ -771,15 +427,12 @@ 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 - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine l_base_free_buffer + 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 ! !> Function base_maybe_free_buffer: @@ -792,17 +445,12 @@ 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 - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine l_base_maybe_free_buffer + 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 ! !> Function base_free_comid: @@ -812,113 +460,106 @@ 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 + 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 - 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 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 +571,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 +583,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 +595,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 +607,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 +619,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 +632,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 +645,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 +673,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 +686,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 +699,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,33 +713,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_) :: info + integer(psb_ipk_), optional :: n + end function l_base_get_vect + end interface ! ! Reset all values @@ -1126,32 +731,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,43 +745,19 @@ 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 + 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 - 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_check_addr(x) + class(psb_l_base_vect_type), intent(inout) :: x + end subroutine l_base_check_addr + end interface @@ -1211,18 +773,14 @@ 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 +790,59 @@ 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 +853,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,55 +875,34 @@ 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 end module psb_l_base_vect_mod @@ -1528,8 +1043,6 @@ module psb_l_base_multivect_mod module procedure constructor, size_const end interface psb_l_base_multivect -contains - ! ! Constructors. ! @@ -1538,29 +1051,23 @@ contains !! \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 - - + interface + module function constructor(x) result(this) + integer(psb_lpk_) :: x(:,:) + type(psb_l_base_multivect_type) :: this + end function constructor + end interface + !> 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 + interface + module function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_l_base_multivect_type) :: this + end function size_const + end interface ! ! Build from a sample @@ -1571,20 +1078,12 @@ 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 + end subroutine l_base_mlv_bld_x + end interface ! ! Create with size, but no initialization @@ -1595,17 +1094,13 @@ 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 + logical, intent(in), optional :: scratch + end subroutine l_base_mlv_bld_n + end interface !> Function base_mlv_all: !! \memberof psb_l_base_multivect_type @@ -1614,21 +1109,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 +1123,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) + 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 - 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 - - 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 +1165,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 +1181,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 +1200,14 @@ 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 +1217,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 +1328,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 +1340,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 +1352,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 +1364,12 @@ 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) + implicit none + 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 +1377,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 +1390,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,34 +1403,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 +1431,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) + 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 - end function l_base_mlv_get_nrows - - 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 +1451,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,13 +1464,12 @@ 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 +1478,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,15 +1494,13 @@ 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) + implicit none + 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 @@ -2265,88 +1508,56 @@ contains !! \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 - - 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 + 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 - 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 +1571,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 +1588,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 +1607,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,47 +1624,26 @@ 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: @@ -2491,72 +1658,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 +1702,9 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine l_base_mlv_device_wait() - implicit none - - end subroutine l_base_mlv_device_wait + interface + module subroutine l_base_mlv_device_wait() + end subroutine l_base_mlv_device_wait + end interface end module psb_l_base_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 e6248aae..58cdd9a9 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_s_base_vect_mod procedure, pass(x) :: set_vect => s_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> s_base_get_entry + procedure, pass(x) :: set_entry=> s_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -257,8 +258,6 @@ module psb_s_base_vect_mod module procedure constructor, size_const end interface psb_s_base_vect -contains - ! ! Constructors. ! @@ -267,30 +266,31 @@ contains !! \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 + interface + module 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 + end function constructor + end interface !> 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 + interface + module function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_s_base_vect_type) :: this + integer(psb_ipk_) :: info + + end function size_const + end interface ! + ! Build from a sample ! @@ -299,36 +299,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 @@ -339,50 +316,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 @@ -391,21 +344,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 @@ -413,43 +358,22 @@ 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. ! @@ -477,153 +401,25 @@ 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 ! !> Function base_zero @@ -631,18 +427,11 @@ 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 - - if (allocated(x%v)) then - !$omp workshare - x%v(:)=szero - !$omp end workshare - end if - call x%set_host() - end subroutine s_base_zero + interface + module subroutine s_base_zero(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_zero + end interface ! @@ -658,75 +447,14 @@ contains !! \param info return code !! ! - - 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. @@ -741,75 +469,14 @@ contains !! \param info return code !! ! - - 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: @@ -819,22 +486,12 @@ 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 - - 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 + 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 ! !> Function base_free_buffer: @@ -844,15 +501,12 @@ 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 - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine s_base_free_buffer + 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 ! !> Function base_maybe_free_buffer: @@ -865,17 +519,12 @@ 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 - - info = 0 - if (psb_get_maybe_free_buffer())& - & call x%free_buffer(info) - - end subroutine s_base_maybe_free_buffer + 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 ! !> Function base_free_comid: @@ -885,113 +534,106 @@ 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 + 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 - 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 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 @@ -1003,11 +645,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: @@ -1015,11 +657,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: @@ -1027,11 +669,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: @@ -1039,11 +681,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: @@ -1051,13 +693,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 @@ -1065,13 +706,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 @@ -1079,32 +719,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. @@ -1115,15 +747,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 @@ -1131,15 +760,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 @@ -1147,12 +773,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 ! ! @@ -1162,33 +787,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_) :: info + integer(psb_ipk_), optional :: n + end function s_base_get_vect + end interface ! ! Reset all values @@ -1199,32 +805,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 @@ -1232,43 +819,19 @@ 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 + 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 - 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_check_addr(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_check_addr + end interface ! @@ -1280,16 +843,21 @@ 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(in) :: x - integer(psb_ipk_), intent(in) :: index - real(psb_spk_) :: res - - res = 0 - if (allocated(x%v)) res = x%v(index) - - end function s_base_get_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 @@ -1299,39 +867,18 @@ 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 + interface + module subroutine s_base_absval1(x) + class(psb_s_base_vect_type), intent(inout) :: x + end subroutine s_base_absval1 + end interface - 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_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 @@ -1343,30 +890,14 @@ 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 s_base_dot_v + end interface + ! ! Base workhorse is good old BLAS1 ! @@ -1377,17 +908,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. @@ -1403,20 +931,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. @@ -1434,21 +957,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. @@ -1463,20 +981,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. @@ -1492,21 +1005,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. @@ -1525,47 +1033,28 @@ 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: @@ -1582,19 +1071,13 @@ 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 @@ -1603,25 +1086,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 @@ -1634,87 +1105,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 @@ -1726,68 +1126,36 @@ 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 @@ -1795,19 +1163,13 @@ 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 x%div(x%v,y%v,info) - - end subroutine s_base_div_v + 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 ! !> Function base_div_v2 !! \memberof psb_s_base_vect_type @@ -1815,21 +1177,14 @@ 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 (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info) - - - 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 @@ -1837,20 +1192,14 @@ 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() - 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 @@ -1858,21 +1207,15 @@ 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 @@ -1880,25 +1223,14 @@ 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 @@ -1907,35 +1239,15 @@ 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 @@ -1943,20 +1255,13 @@ 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 @@ -1965,20 +1270,14 @@ 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 + logical, intent(in) :: flag + end subroutine s_base_inv_v_check + end interface ! !> Function base_inv_a2 !! \memberof psb_s_base_vect_type @@ -1987,24 +1286,13 @@ 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 @@ -2014,35 +1302,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 @@ -2053,29 +1320,14 @@ 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 @@ -2085,19 +1337,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 ! @@ -2106,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 @@ -2133,70 +1367,40 @@ 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: 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 !! \memberof psb_s_base_vect_type @@ -2205,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 @@ -2229,29 +1426,14 @@ 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 ! @@ -2259,24 +1441,13 @@ contains !! \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 ! @@ -2291,18 +1462,14 @@ 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 ! @@ -2312,77 +1479,59 @@ 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 @@ -2393,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: @@ -2419,55 +1564,34 @@ 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 @@ -2482,56 +1606,15 @@ 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 @@ -2545,21 +1628,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 ! @@ -2571,28 +1648,14 @@ 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 @@ -2602,18 +1665,14 @@ 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 end module psb_s_base_vect_mod @@ -2785,8 +1844,6 @@ module psb_s_base_multivect_mod module procedure constructor, size_const end interface psb_s_base_multivect -contains - ! ! Constructors. ! @@ -2795,29 +1852,23 @@ contains !! \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 - - + interface + module function constructor(x) result(this) + real(psb_spk_) :: x(:,:) + type(psb_s_base_multivect_type) :: this + end function constructor + end interface + !> 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 + interface + module function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_s_base_multivect_type) :: this + end function size_const + end interface ! ! Build from a sample @@ -2828,20 +1879,12 @@ 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 + end subroutine s_base_mlv_bld_x + end interface ! ! Create with size, but no initialization @@ -2852,17 +1895,13 @@ 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 + logical, intent(in), optional :: scratch + end subroutine s_base_mlv_bld_n + end interface !> Function base_mlv_all: !! \memberof psb_s_base_multivect_type @@ -2871,21 +1910,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 @@ -2893,34 +1924,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) - - end subroutine s_base_mlv_mold + 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 - 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. @@ -2949,129 +1966,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 @@ -3079,16 +1982,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. @@ -3103,81 +2001,14 @@ 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: @@ -3187,118 +2018,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 @@ -3310,11 +2129,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: @@ -3322,11 +2141,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: @@ -3334,11 +2153,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: @@ -3346,11 +2165,12 @@ 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) + implicit none + class(psb_s_base_multivect_type), intent(inout) :: x + end subroutine s_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3358,13 +2178,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 @@ -3372,13 +2191,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 @@ -3386,34 +2204,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. ! @@ -3423,25 +2232,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 + 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 - res = 0 - if (allocated(x%v)) res = size(x%v,1) - - end function s_base_mlv_get_nrows - - 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 @@ -3449,15 +2252,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 @@ -3465,13 +2265,12 @@ 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 + ! ! ! @@ -3480,22 +2279,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 @@ -3506,15 +2295,13 @@ 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) + implicit none + 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 @@ -3522,23 +2309,12 @@ contains !! \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 @@ -3550,36 +2326,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 @@ -3591,23 +2344,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. @@ -3623,30 +2367,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. @@ -3661,26 +2391,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: @@ -3697,31 +2417,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 + 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 - info = 0 - if (x%is_dev()) call x%sync() - call y%mlt(x%v,info) - - end subroutine s_base_mlv_mlt_mv - - 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 @@ -3730,21 +2440,13 @@ 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 @@ -3753,21 +2455,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 @@ -3780,53 +2474,15 @@ 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 @@ -3839,40 +2495,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(:) @@ -3888,7 +2522,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(:) @@ -3912,16 +2545,12 @@ 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 @@ -3930,64 +2559,39 @@ 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 + 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 ! @@ -3996,96 +2600,62 @@ 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 + 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(:)) @@ -4099,23 +2669,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 ! @@ -4125,19 +2686,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 @@ -4148,24 +2705,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 ! @@ -4175,47 +2722,26 @@ 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: @@ -4230,72 +2756,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: @@ -4303,9 +2800,9 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine s_base_mlv_device_wait() - implicit none - - end subroutine s_base_mlv_device_wait + interface + module subroutine s_base_mlv_device_wait() + end subroutine s_base_mlv_device_wait + end interface 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 8c5841a7..cd011667 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_s_vect_mod procedure, pass(x) :: check_addr => s_vect_check_addr procedure, pass(x) :: get_entry => s_vect_get_entry + procedure, pass(x) :: set_entry => s_vect_set_entry procedure, pass(x) :: dot_v => s_vect_dot_v procedure, pass(x) :: dot_a => s_vect_dot_a @@ -862,13 +863,22 @@ contains function s_vect_get_entry(x,index) result(res) implicit none - class(psb_s_vect_type), intent(in) :: x + class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_spk_) :: res - res = 0 + 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 @@ -1430,7 +1440,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = szero + res = HUGE(szero) end if end function s_vect_min diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index 87d911e7..fc183140 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_z_base_vect_mod procedure, pass(x) :: set_vect => z_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> z_base_get_entry + procedure, pass(x) :: set_entry=> z_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -250,8 +251,6 @@ module psb_z_base_vect_mod module procedure constructor, size_const end interface psb_z_base_vect -contains - ! ! Constructors. ! @@ -260,30 +259,31 @@ contains !! \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 + interface + module 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 + end function constructor + end interface !> 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 + interface + module function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_z_base_vect_type) :: this + integer(psb_ipk_) :: info + + end function size_const + end interface ! + ! Build from a sample ! @@ -292,36 +292,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 @@ -332,50 +309,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 @@ -384,21 +337,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 @@ -406,43 +351,22 @@ 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. ! @@ -470,153 +394,25 @@ 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 ! !> Function base_zero @@ -624,18 +420,11 @@ 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 - - if (allocated(x%v)) then - !$omp workshare - x%v(:)=zzero - !$omp end workshare - end if - call x%set_host() - end subroutine z_base_zero + interface + module subroutine z_base_zero(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_zero + end interface ! @@ -651,75 +440,14 @@ contains !! \param info return code !! ! - - 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. @@ -734,75 +462,14 @@ contains !! \param info return code !! ! - - 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: @@ -812,22 +479,12 @@ 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 - - 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 + 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 ! !> Function base_free_buffer: @@ -837,15 +494,12 @@ 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 - - if (allocated(x%combuf)) & - & deallocate(x%combuf,stat=info) - end subroutine z_base_free_buffer + 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 ! !> Function base_maybe_free_buffer: @@ -858,17 +512,12 @@ 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) - - end subroutine z_base_maybe_free_buffer + 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 ! !> Function base_free_comid: @@ -878,113 +527,106 @@ 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 + 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 - 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 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 @@ -996,11 +638,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: @@ -1008,11 +650,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: @@ -1020,11 +662,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: @@ -1032,11 +674,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: @@ -1044,13 +686,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 @@ -1058,13 +699,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 @@ -1072,32 +712,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. @@ -1108,15 +740,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 @@ -1124,15 +753,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 @@ -1140,12 +766,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 ! ! @@ -1155,33 +780,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_) :: info + integer(psb_ipk_), optional :: n + end function z_base_get_vect + end interface ! ! Reset all values @@ -1192,32 +798,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 @@ -1225,43 +812,19 @@ 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 + 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 - write(0,*) 'Check addr: base version, do nothing' - - end subroutine z_base_check_addr + 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 ! @@ -1273,16 +836,21 @@ 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(in) :: x - integer(psb_ipk_), intent(in) :: index - complex(psb_dpk_) :: res - - res = 0 - if (allocated(x%v)) res = x%v(index) - - end function z_base_get_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 @@ -1292,39 +860,18 @@ 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 + interface + module subroutine z_base_absval1(x) + class(psb_z_base_vect_type), intent(inout) :: x + end subroutine z_base_absval1 + end interface - 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_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 @@ -1336,30 +883,14 @@ 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 z_base_dot_v + end interface + ! ! Base workhorse is good old BLAS1 ! @@ -1370,17 +901,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. @@ -1396,20 +924,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. @@ -1427,21 +950,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. @@ -1456,20 +974,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. @@ -1485,21 +998,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. @@ -1518,47 +1026,28 @@ 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: @@ -1575,19 +1064,13 @@ 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 @@ -1596,25 +1079,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 @@ -1627,87 +1098,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 @@ -1719,68 +1119,36 @@ 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 @@ -1788,19 +1156,13 @@ 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 x%div(x%v,y%v,info) - - end subroutine z_base_div_v + 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 ! !> Function base_div_v2 !! \memberof psb_z_base_vect_type @@ -1808,21 +1170,14 @@ 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 (z%is_dev()) call z%sync() - call z%div(x%v,y%v,info) - - - 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 @@ -1830,20 +1185,14 @@ 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() - 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 @@ -1851,21 +1200,15 @@ 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 @@ -1873,25 +1216,14 @@ 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 @@ -1900,35 +1232,15 @@ 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 @@ -1936,20 +1248,13 @@ 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 @@ -1958,20 +1263,14 @@ 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 + logical, intent(in) :: flag + end subroutine z_base_inv_v_check + end interface ! !> Function base_inv_a2 !! \memberof psb_z_base_vect_type @@ -1980,24 +1279,13 @@ 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 @@ -2007,35 +1295,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 @@ -2046,29 +1313,14 @@ 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 @@ -2078,19 +1330,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 ! @@ -2099,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 @@ -2126,41 +1360,26 @@ 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 ! @@ -2168,24 +1387,13 @@ contains !! \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 ! @@ -2200,18 +1408,14 @@ 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 ! @@ -2221,77 +1425,59 @@ 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 @@ -2302,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: @@ -2328,55 +1510,34 @@ 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 ! @@ -2388,28 +1549,14 @@ 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 @@ -2419,18 +1566,14 @@ 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 end module psb_z_base_vect_mod @@ -2602,8 +1745,6 @@ module psb_z_base_multivect_mod module procedure constructor, size_const end interface psb_z_base_multivect -contains - ! ! Constructors. ! @@ -2612,29 +1753,23 @@ contains !! \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 - - + interface + module function constructor(x) result(this) + complex(psb_dpk_) :: x(:,:) + type(psb_z_base_multivect_type) :: this + end function constructor + end interface + !> 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 + interface + module function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_z_base_multivect_type) :: this + end function size_const + end interface ! ! Build from a sample @@ -2645,20 +1780,12 @@ 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 + end subroutine z_base_mlv_bld_x + end interface ! ! Create with size, but no initialization @@ -2669,17 +1796,13 @@ 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 + logical, intent(in), optional :: scratch + end subroutine z_base_mlv_bld_n + end interface !> Function base_mlv_all: !! \memberof psb_z_base_multivect_type @@ -2688,21 +1811,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 @@ -2710,34 +1825,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 + 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 - 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 - - 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. @@ -2766,129 +1867,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 @@ -2896,16 +1883,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. @@ -2920,81 +1902,14 @@ 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: @@ -3004,118 +1919,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 @@ -3127,11 +2030,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: @@ -3139,11 +2042,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: @@ -3151,11 +2054,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: @@ -3163,11 +2066,12 @@ 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) + implicit none + class(psb_z_base_multivect_type), intent(inout) :: x + end subroutine z_base_mlv_set_sync + end interface ! !> Function base_mlv_is_dev: @@ -3175,13 +2079,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 @@ -3189,13 +2092,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 @@ -3203,34 +2105,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. ! @@ -3240,25 +2133,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 - - 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) + 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 - 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 @@ -3266,15 +2153,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 @@ -3282,13 +2166,12 @@ 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 + ! ! ! @@ -3297,22 +2180,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 @@ -3323,15 +2196,13 @@ 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) + implicit none + 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 @@ -3339,23 +2210,12 @@ contains !! \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 @@ -3367,36 +2227,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 @@ -3408,23 +2245,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. @@ -3440,30 +2268,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. @@ -3478,26 +2292,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: @@ -3514,31 +2318,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) - - end subroutine z_base_mlv_mlt_mv + 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 - 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 @@ -3547,21 +2341,13 @@ 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 @@ -3570,21 +2356,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 @@ -3597,53 +2375,15 @@ 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 @@ -3656,40 +2396,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(:) @@ -3705,7 +2423,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(:) @@ -3729,16 +2446,12 @@ 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 @@ -3747,64 +2460,39 @@ 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 + 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 ! @@ -3813,96 +2501,62 @@ 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 + 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(:)) @@ -3916,23 +2570,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 ! @@ -3942,19 +2587,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 @@ -3965,24 +2606,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 ! @@ -3992,47 +2623,26 @@ 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: @@ -4047,72 +2657,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: @@ -4120,9 +2701,9 @@ contains !! \brief device_wait: base version is a no-op. !! ! - subroutine z_base_mlv_device_wait() - implicit none - - end subroutine z_base_mlv_device_wait + interface + module subroutine z_base_mlv_device_wait() + end subroutine z_base_mlv_device_wait + end interface 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 082b62ea..5fe51052 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_z_vect_mod procedure, pass(x) :: check_addr => z_vect_check_addr procedure, pass(x) :: get_entry => z_vect_get_entry + procedure, pass(x) :: set_entry => z_vect_set_entry procedure, pass(x) :: dot_v => z_vect_dot_v procedure, pass(x) :: dot_a => z_vect_dot_a @@ -855,13 +856,22 @@ contains function z_vect_get_entry(x,index) result(res) implicit none - class(psb_z_vect_type), intent(in) :: x + class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_dpk_) :: res - res = 0 + 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 diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index 148ddf59..bb99662c 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -454,6 +454,17 @@ Module psb_c_tools_mod end function end interface + interface psb_setelem + subroutine psb_c_setelem(index,val,x,desc_a,info) + import + type(psb_c_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) ::val + end subroutine psb_c_setelem + end interface + interface psb_remap subroutine psb_c_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index 97f70fc1..9b289aad 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -454,6 +454,17 @@ Module psb_d_tools_mod end function end interface + interface psb_setelem + subroutine psb_d_setelem(index,val,x,desc_a,info) + import + type(psb_d_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) ::val + end subroutine psb_d_setelem + end interface + interface psb_remap subroutine psb_d_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index c87607bc..40bf3418 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -454,6 +454,17 @@ Module psb_s_tools_mod end function end interface + interface psb_setelem + subroutine psb_s_setelem(index,val,x,desc_a,info) + import + type(psb_s_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) ::val + end subroutine psb_s_setelem + end interface + interface psb_remap subroutine psb_s_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index 8a6c2d34..3ecf759a 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -454,6 +454,17 @@ Module psb_z_tools_mod end function end interface + interface psb_setelem + subroutine psb_z_setelem(index,val,x,desc_a,info) + import + type(psb_z_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) ::val + end subroutine psb_z_setelem + end interface + interface psb_remap subroutine psb_z_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index 37f400f0..971dfb6e 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -4,7 +4,11 @@ include ../../../Make.inc # The object files # BOBJS=psb_base_mat_impl.o \ - psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o + psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o \ + psb_i_base_vect_impl.o psb_l_base_vect_impl.o \ + psb_s_base_vect_impl.o psb_d_base_vect_impl.o \ + psb_c_base_vect_impl.o psb_z_base_vect_impl.o + #\ psb_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\ 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 00000000..de656555 --- /dev/null +++ b/base/serial/impl/psb_c_base_vect_impl.F90 @@ -0,0 +1,3841 @@ +! +! 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 +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + ! + + !> 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) + 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + module subroutine c_base_reinit(x, info,clear) + 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 + + + ! + ! 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) + 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 + + + module subroutine c_base_ins_v(n,irl,val,dupl,x,maxr,info) + 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 + + + + ! + !> Function base_zero + !! \memberof psb_c_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine c_base_zero(x) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_free: + !! \memberof psb_c_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine c_base_free(x, info) + implicit none + 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) + implicit none + 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) + 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) + + 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) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_get_sizeof + !! \memberof psb_c_base_vect_type + !! \brief Size in bytes + !! + ! + module 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 + + + ! + !> Function base_get_fmt + !! \memberof psb_c_base_vect_type + !! \brief Format + !! + ! + module function c_base_get_fmt() result(res) + implicit none + 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) + 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 + + + + ! + !> 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) + 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 + + + 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine c_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + 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 + + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + module subroutine c_base_mlt_av(alpha,x,y,beta,z,info) + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: x(:) + class(psb_c_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) + 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 + + ! + !> 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) + 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 x%div(x%v,y%v,info) + + end subroutine c_base_div_v + + ! + !> 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) + 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 (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + 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) + 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() + 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine c_base_gthzbuf(i,n,idx,x) + 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 + + ! + !> 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() + implicit none + + 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) + 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 + + + module subroutine c_base_new_comid(n,x,info) + 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 + + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine c_base_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine c_base_sctb_buf(i,n,idx,beta,y) + 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 + + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + +end submodule psb_c_base_vect_impl + + +submodule (psb_c_base_multivect_mod) psb_c_base_multivect_impl + use psb_realloc_mod + use psi_serial_mod + use psb_string_mod +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + module subroutine c_base_mlv_reinit(x, info) + implicit none + 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) + 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 + + + ! + !> Function base_mlv_zero + !! \memberof psb_c_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine c_base_mlv_zero(x) + 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 + + + + ! + ! 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) + 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: + !! \memberof psb_c_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine c_base_mlv_free(x, info) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + + ! + ! 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) + 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 + + + module 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 + + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_c_base_multivect_type + !! \brief Size in bytesa + !! + ! + module 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 + + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_c_base_multivect_type + !! \brief Format + !! + ! + module function c_base_mlv_get_fmt() result(res) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + + ! + ! 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) + 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) + + end subroutine c_base_mlv_mlt_mv + + + module subroutine c_base_mlv_mlt_mv_v(x, y, info) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + +!!$ +!!$ subroutine c_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ implicit none +!!$ complex(psb_spk_), intent(in) :: alpha,beta +!!$ complex(psb_spk_), intent(in) :: x(:) +!!$ class(psb_c_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) +!!$ implicit none +!!$ 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + ! 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) + 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 + + + module 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 + + + + module function c_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function c_base_mlv_use_buffer + + module subroutine c_base_mlv_new_buffer(n,x,info) + 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 + + + module subroutine c_base_mlv_new_comid(n,x,info) + 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 + + + + module subroutine c_base_mlv_maybe_free_buffer(x,info) + 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 + + + module subroutine c_base_mlv_free_buffer(x,info) + 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 + + + module subroutine c_base_mlv_free_comid(x,info) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine c_base_mlv_gthzbuf(i,ixb,n,idx,x) + 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 + + + ! + ! 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) + 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 + + + module subroutine c_base_mlv_sctbr2(n,idx,x,beta,y) + 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 + + + module subroutine c_base_mlv_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine c_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + 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 + + + ! + !> 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() + implicit none + + end subroutine c_base_mlv_device_wait + + +end submodule psb_c_base_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 00000000..24f35b95 --- /dev/null +++ b/base/serial/impl/psb_d_base_vect_impl.F90 @@ -0,0 +1,4018 @@ +! +! 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 +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + ! + + !> 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) + 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + module subroutine d_base_reinit(x, info,clear) + 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 + + + ! + ! 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) + 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 + + + module subroutine d_base_ins_v(n,irl,val,dupl,x,maxr,info) + 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 + + + + ! + !> Function base_zero + !! \memberof psb_d_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine d_base_zero(x) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_free: + !! \memberof psb_d_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine d_base_free(x, info) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_get_sizeof + !! \memberof psb_d_base_vect_type + !! \brief Size in bytes + !! + ! + module 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 + + + ! + !> Function base_get_fmt + !! \memberof psb_d_base_vect_type + !! \brief Format + !! + ! + module function d_base_get_fmt() result(res) + implicit none + 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) + 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 + + + + ! + !> 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) + 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 + + + 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine d_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + 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 + + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + module subroutine d_base_mlt_av(alpha,x,y,beta,z,info) + implicit none + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(in) :: x(:) + class(psb_d_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) + 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 + + ! + !> 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) + 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 x%div(x%v,y%v,info) + + end subroutine d_base_div_v + + ! + !> 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) + 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 (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + 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) + 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() + 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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() + res = HUGE(done) +#if defined(PSB_OPENMP) + !$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: 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine d_base_gthzbuf(i,n,idx,x) + 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 + + ! + !> 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() + implicit none + + 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) + 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 + + + module subroutine d_base_new_comid(n,x,info) + 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 + + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine d_base_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine d_base_sctb_buf(i,n,idx,beta,y) + 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 + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + +end submodule psb_d_base_vect_impl + + +submodule (psb_d_base_multivect_mod) psb_d_base_multivect_impl + use psb_realloc_mod + use psi_serial_mod + use psb_string_mod +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + + + ! + ! 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) + 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 + + + !> 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) + 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) + + end subroutine d_base_mlv_mold + + + module subroutine d_base_mlv_reinit(x, info) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_mlv_zero + !! \memberof psb_d_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine d_base_mlv_zero(x) + 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 + + + + ! + ! 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) + 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: + !! \memberof psb_d_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine d_base_mlv_free(x, info) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + + ! + ! 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) + 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 + + + module 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 + + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_d_base_multivect_type + !! \brief Size in bytesa + !! + ! + module 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 + + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_d_base_multivect_type + !! \brief Format + !! + ! + module function d_base_mlv_get_fmt() result(res) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + + ! + ! 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) + 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 + + + module subroutine d_base_mlv_mlt_mv_v(x, y, info) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + +!!$ +!!$ subroutine d_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ implicit none +!!$ real(psb_dpk_), intent(in) :: alpha,beta +!!$ real(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_d_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) +!!$ implicit none +!!$ 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + ! 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) + 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 + + + module 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 + + + + module function d_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function d_base_mlv_use_buffer + + module subroutine d_base_mlv_new_buffer(n,x,info) + 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 + + + module subroutine d_base_mlv_new_comid(n,x,info) + 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 + + + + module subroutine d_base_mlv_maybe_free_buffer(x,info) + 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 + + + module subroutine d_base_mlv_free_buffer(x,info) + 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 + + + module subroutine d_base_mlv_free_comid(x,info) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine d_base_mlv_gthzbuf(i,ixb,n,idx,x) + 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 + + + ! + ! 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) + 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 + + + module subroutine d_base_mlv_sctbr2(n,idx,x,beta,y) + 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 + + + module subroutine d_base_mlv_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine d_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + 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 + + + ! + !> 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() + implicit none + + end subroutine d_base_mlv_device_wait + + +end submodule psb_d_base_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 00000000..1c13aef0 --- /dev/null +++ b/base/serial/impl/psb_i_base_vect_impl.F90 @@ -0,0 +1,2354 @@ +! +! 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 +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + ! + + !> 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) + 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + module subroutine i_base_reinit(x, info,clear) + 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 + + 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) + 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 + + + module subroutine i_base_ins_v(n,irl,val,dupl,x,maxr,info) + 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 + + + + ! + !> Function base_zero + !! \memberof psb_i_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine i_base_zero(x) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_free: + !! \memberof psb_i_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine i_base_free(x, info) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_get_sizeof + !! \memberof psb_i_base_vect_type + !! \brief Size in bytes + !! + ! + module 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 + + + ! + !> Function base_get_fmt + !! \memberof psb_i_base_vect_type + !! \brief Format + !! + ! + module function i_base_get_fmt() result(res) + implicit none + 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) + 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 + + + + ! + !> 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) + 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 + + + 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine i_base_gthzbuf(i,n,idx,x) + 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 + + ! + !> 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() + implicit none + + 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) + 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 + + + module subroutine i_base_new_comid(n,x,info) + 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 + + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine i_base_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine i_base_sctb_buf(i,n,idx,beta,y) + 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 + + + +end submodule psb_i_base_vect_impl + + +submodule (psb_i_base_multivect_mod) psb_i_base_multivect_impl + use psb_realloc_mod + use psi_serial_mod + use psb_string_mod +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + module subroutine i_base_mlv_reinit(x, info) + implicit none + 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) + 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 + + + ! + !> Function base_mlv_zero + !! \memberof psb_i_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine i_base_mlv_zero(x) + 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 + + + + ! + ! 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) + 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: + !! \memberof psb_i_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine i_base_mlv_free(x, info) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + + ! + ! 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) + 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 + + + module 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 + + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_i_base_multivect_type + !! \brief Size in bytesa + !! + ! + module 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 + + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_i_base_multivect_type + !! \brief Format + !! + ! + module function i_base_mlv_get_fmt() result(res) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + module function i_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function i_base_mlv_use_buffer + + module subroutine i_base_mlv_new_buffer(n,x,info) + implicit none + 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) + 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 + + + + module subroutine i_base_mlv_maybe_free_buffer(x,info) + 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 + + + module subroutine i_base_mlv_free_buffer(x,info) + 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 + + + module subroutine i_base_mlv_free_comid(x,info) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine i_base_mlv_gthzbuf(i,ixb,n,idx,x) + 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 + + + ! + ! 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) + 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 + + + module subroutine i_base_mlv_sctbr2(n,idx,x,beta,y) + 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 + + + module subroutine i_base_mlv_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine i_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + 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 + + + ! + !> 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() + implicit none + + end subroutine i_base_mlv_device_wait + + +end submodule psb_i_base_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 00000000..05905e70 --- /dev/null +++ b/base/serial/impl/psb_l_base_vect_impl.F90 @@ -0,0 +1,2354 @@ +! +! 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 +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + ! + + !> 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) + 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + module subroutine l_base_reinit(x, info,clear) + 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 + + 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) + 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 + + + module subroutine l_base_ins_v(n,irl,val,dupl,x,maxr,info) + 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 + + + + ! + !> Function base_zero + !! \memberof psb_l_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine l_base_zero(x) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_free: + !! \memberof psb_l_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine l_base_free(x, info) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_get_sizeof + !! \memberof psb_l_base_vect_type + !! \brief Size in bytes + !! + ! + module 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 + + + ! + !> Function base_get_fmt + !! \memberof psb_l_base_vect_type + !! \brief Format + !! + ! + module function l_base_get_fmt() result(res) + implicit none + 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) + 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 + + + + ! + !> 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) + 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 + + + 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine l_base_gthzbuf(i,n,idx,x) + 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 + + ! + !> 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() + implicit none + + 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) + 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 + + + module subroutine l_base_new_comid(n,x,info) + 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 + + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine l_base_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine l_base_sctb_buf(i,n,idx,beta,y) + 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 + + + +end submodule psb_l_base_vect_impl + + +submodule (psb_l_base_multivect_mod) psb_l_base_multivect_impl + use psb_realloc_mod + use psi_serial_mod + use psb_string_mod +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + module subroutine l_base_mlv_reinit(x, info) + implicit none + 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) + 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 + + + ! + !> Function base_mlv_zero + !! \memberof psb_l_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine l_base_mlv_zero(x) + 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 + + + + ! + ! 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) + 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: + !! \memberof psb_l_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine l_base_mlv_free(x, info) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + + ! + ! 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) + 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 + + + module 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 + + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_l_base_multivect_type + !! \brief Size in bytesa + !! + ! + module 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 + + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_l_base_multivect_type + !! \brief Format + !! + ! + module function l_base_mlv_get_fmt() result(res) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + module function l_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function l_base_mlv_use_buffer + + module subroutine l_base_mlv_new_buffer(n,x,info) + implicit none + 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) + 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 + + + + module subroutine l_base_mlv_maybe_free_buffer(x,info) + 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 + + + module subroutine l_base_mlv_free_buffer(x,info) + 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 + + + module subroutine l_base_mlv_free_comid(x,info) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine l_base_mlv_gthzbuf(i,ixb,n,idx,x) + 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 + + + ! + ! 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) + 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 + + + module subroutine l_base_mlv_sctbr2(n,idx,x,beta,y) + 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 + + + module subroutine l_base_mlv_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine l_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + 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 + + + ! + !> 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() + implicit none + + end subroutine l_base_mlv_device_wait + + +end submodule psb_l_base_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 00000000..bbd2f100 --- /dev/null +++ b/base/serial/impl/psb_s_base_vect_impl.F90 @@ -0,0 +1,4018 @@ +! +! 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 +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + ! + + !> 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) + 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + module subroutine s_base_reinit(x, info,clear) + 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 + + + ! + ! 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) + 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 + + + module subroutine s_base_ins_v(n,irl,val,dupl,x,maxr,info) + 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 + + + + ! + !> Function base_zero + !! \memberof psb_s_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine s_base_zero(x) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_free: + !! \memberof psb_s_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine s_base_free(x, info) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_get_sizeof + !! \memberof psb_s_base_vect_type + !! \brief Size in bytes + !! + ! + module 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 + + + ! + !> Function base_get_fmt + !! \memberof psb_s_base_vect_type + !! \brief Format + !! + ! + module function s_base_get_fmt() result(res) + implicit none + 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) + 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 + + + + ! + !> 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) + 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 + + + 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine s_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + 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 + + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + module subroutine s_base_mlt_av(alpha,x,y,beta,z,info) + implicit none + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(in) :: x(:) + class(psb_s_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) + 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 + + ! + !> 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) + 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 x%div(x%v,y%v,info) + + end subroutine s_base_div_v + + ! + !> 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) + 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 (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + 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) + 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() + 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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() + res = HUGE(sone) +#if defined(PSB_OPENMP) + !$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: 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine s_base_gthzbuf(i,n,idx,x) + 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 + + ! + !> 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() + implicit none + + 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) + 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 + + + module subroutine s_base_new_comid(n,x,info) + 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 + + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine s_base_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine s_base_sctb_buf(i,n,idx,beta,y) + 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 + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + +end submodule psb_s_base_vect_impl + + +submodule (psb_s_base_multivect_mod) psb_s_base_multivect_impl + use psb_realloc_mod + use psi_serial_mod + use psb_string_mod +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + + + ! + ! 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) + 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 + + + !> 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) + 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) + + end subroutine s_base_mlv_mold + + + module subroutine s_base_mlv_reinit(x, info) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_mlv_zero + !! \memberof psb_s_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine s_base_mlv_zero(x) + 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 + + + + ! + ! 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) + 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: + !! \memberof psb_s_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine s_base_mlv_free(x, info) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + + ! + ! 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) + 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 + + + module 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 + + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_s_base_multivect_type + !! \brief Size in bytesa + !! + ! + module 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 + + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_s_base_multivect_type + !! \brief Format + !! + ! + module function s_base_mlv_get_fmt() result(res) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + + ! + ! 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) + 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 + + + module subroutine s_base_mlv_mlt_mv_v(x, y, info) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + +!!$ +!!$ subroutine s_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ implicit none +!!$ real(psb_spk_), intent(in) :: alpha,beta +!!$ real(psb_spk_), intent(in) :: x(:) +!!$ class(psb_s_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) +!!$ implicit none +!!$ 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + ! 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) + 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 + + + module 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 + + + + module function s_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function s_base_mlv_use_buffer + + module subroutine s_base_mlv_new_buffer(n,x,info) + 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 + + + module subroutine s_base_mlv_new_comid(n,x,info) + 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 + + + + module subroutine s_base_mlv_maybe_free_buffer(x,info) + 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 + + + module subroutine s_base_mlv_free_buffer(x,info) + 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 + + + module subroutine s_base_mlv_free_comid(x,info) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine s_base_mlv_gthzbuf(i,ixb,n,idx,x) + 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 + + + ! + ! 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) + 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 + + + module subroutine s_base_mlv_sctbr2(n,idx,x,beta,y) + 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 + + + module subroutine s_base_mlv_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine s_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + 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 + + + ! + !> 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() + implicit none + + end subroutine s_base_mlv_device_wait + + +end submodule psb_s_base_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 00000000..4368539a --- /dev/null +++ b/base/serial/impl/psb_z_base_vect_impl.F90 @@ -0,0 +1,3841 @@ +! +! 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 +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + ! + + !> 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) + 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + !> 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) + 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 + + + module subroutine z_base_reinit(x, info,clear) + 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 + + + ! + ! 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) + 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 + + + module subroutine z_base_ins_v(n,irl,val,dupl,x,maxr,info) + 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 + + + + ! + !> Function base_zero + !! \memberof psb_z_base_vect_type + !! \brief Zero out contents + !! + ! + module subroutine z_base_zero(x) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_free: + !! \memberof psb_z_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine z_base_free(x, info) + implicit none + 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) + implicit none + 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) + 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) + + 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) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> Function base_get_sizeof + !! \memberof psb_z_base_vect_type + !! \brief Size in bytes + !! + ! + module 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 + + + ! + !> Function base_get_fmt + !! \memberof psb_z_base_vect_type + !! \brief Format + !! + ! + module function z_base_get_fmt() result(res) + implicit none + 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) + 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 + + + + ! + !> 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) + 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 + + + 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + module 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine z_base_xyzw(m,a,b,c,d,e,f,x, y, z, w,info) + 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 + + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + module subroutine z_base_mlt_av(alpha,x,y,beta,z,info) + implicit none + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: x(:) + class(psb_z_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) + 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 + + ! + !> 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) + 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 x%div(x%v,y%v,info) + + end subroutine z_base_div_v + + ! + !> 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) + 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 (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + 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) + 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() + 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine z_base_gthzbuf(i,n,idx,x) + 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 + + ! + !> 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() + implicit none + + 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) + 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 + + + module subroutine z_base_new_comid(n,x,info) + 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 + + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + module subroutine z_base_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine z_base_sctb_buf(i,n,idx,beta,y) + 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 + + + + ! + !> 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) + 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 + + ! + !> 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) + 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 + +end submodule psb_z_base_vect_impl + + +submodule (psb_z_base_multivect_mod) psb_z_base_multivect_impl + use psb_realloc_mod + use psi_serial_mod + use psb_string_mod +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + module 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. + !! + module 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 + + + ! + ! 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) + 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 + + + !> 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) + 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 + + + module subroutine z_base_mlv_reinit(x, info) + implicit none + 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) + 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 + + + ! + !> Function base_mlv_zero + !! \memberof psb_z_base_multivect_type + !! \brief Zero out contents + !! + ! + module subroutine z_base_mlv_zero(x) + 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 + + + + ! + ! 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) + 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: + !! \memberof psb_z_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + module subroutine z_base_mlv_free(x, info) + 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + module 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 + + + + ! + ! 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + implicit none + 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) + 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 + + + + ! + ! 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) + 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 + + + module 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 + + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_z_base_multivect_type + !! \brief Size in bytesa + !! + ! + module 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 + + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_z_base_multivect_type + !! \brief Format + !! + ! + module function z_base_mlv_get_fmt() result(res) + implicit none + 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + + + ! + ! 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) + 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) + + end subroutine z_base_mlv_mlt_mv + + + module subroutine z_base_mlv_mlt_mv_v(x, y, info) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + +!!$ +!!$ subroutine z_base_mlv_mlt_av(alpha,x,y,beta,z,info) +!!$ implicit none +!!$ complex(psb_dpk_), intent(in) :: alpha,beta +!!$ complex(psb_dpk_), intent(in) :: x(:) +!!$ class(psb_z_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) +!!$ implicit none +!!$ 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) + 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 + + + ! + ! 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) + 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 + + + ! + !> 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) + 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 + + + ! + !> 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) + 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 + + ! + ! 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) + 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 + + + module 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 + + + + module function z_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function z_base_mlv_use_buffer + + module subroutine z_base_mlv_new_buffer(n,x,info) + 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 + + + module subroutine z_base_mlv_new_comid(n,x,info) + 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 + + + + module subroutine z_base_mlv_maybe_free_buffer(x,info) + 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 + + + module subroutine z_base_mlv_free_buffer(x,info) + 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 + + + module subroutine z_base_mlv_free_comid(x,info) + 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 + + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! 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) + 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 + + ! + ! 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) + 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 + + + ! + ! New comm internals impl. + ! + module subroutine z_base_mlv_gthzbuf(i,ixb,n,idx,x) + 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 + + + ! + ! 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) + 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 + + + module subroutine z_base_mlv_sctbr2(n,idx,x,beta,y) + 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 + + + module subroutine z_base_mlv_sctb_x(i,n,idx,x,beta,y) + 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 + + + module subroutine z_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + 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 + + + ! + !> 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() + implicit none + + end subroutine z_base_mlv_device_wait + + +end submodule psb_z_base_multivect_impl diff --git a/base/tools/Makefile b/base/tools/Makefile index 1cd67af5..3d8fce37 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -28,7 +28,8 @@ FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt psb_s_map.o psb_d_map.o psb_c_map.o psb_z_map.o \ psb_s_par_csr_spspmm.o psb_d_par_csr_spspmm.o psb_c_par_csr_spspmm.o psb_z_par_csr_spspmm.o \ psb_s_glob_transpose.o psb_d_glob_transpose.o psb_c_glob_transpose.o psb_z_glob_transpose.o \ - psb_cgetelem.o psb_dgetelem.o psb_sgetelem.o psb_zgetelem.o + psb_cgetelem.o psb_dgetelem.o psb_sgetelem.o psb_zgetelem.o \ + psb_csetelem.o psb_dsetelem.o psb_ssetelem.o psb_zsetelem.o MPFOBJS = psb_icdasb.o psb_ssphalo.o psb_dsphalo.o psb_csphalo.o psb_zsphalo.o \ psb_dcdbldext.o psb_zcdbldext.o psb_scdbldext.o psb_ccdbldext.o \ diff --git a/base/tools/psb_csetelem.f90 b/base/tools/psb_csetelem.f90 new file mode 100644 index 00000000..f186ef1f --- /dev/null +++ b/base/tools/psb_csetelem.f90 @@ -0,0 +1,112 @@ +! +! 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. +! +! Function: psb_c_setelem +! Set entries into a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_c_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +subroutine psb_c_setelem(index,val,x,desc_a,info) + use psb_base_mod, psb_protect_name => psb_c_setelem + use psi_mod + implicit none + + type(psb_c_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: val + + !locals + integer(psb_ipk_) :: localindex(1) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + info = 0 + + gindex(1) = index + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_c_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localindex(1) < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err="Index not in the HALO") + goto 9999 + else + call x%set_entry(localindex(1),val) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_c_setelem + diff --git a/base/tools/psb_dsetelem.f90 b/base/tools/psb_dsetelem.f90 new file mode 100644 index 00000000..3c99e657 --- /dev/null +++ b/base/tools/psb_dsetelem.f90 @@ -0,0 +1,112 @@ +! +! 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. +! +! Function: psb_d_setelem +! Set entries into a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_d_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +subroutine psb_d_setelem(index,val,x,desc_a,info) + use psb_base_mod, psb_protect_name => psb_d_setelem + use psi_mod + implicit none + + type(psb_d_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: val + + !locals + integer(psb_ipk_) :: localindex(1) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + info = 0 + + gindex(1) = index + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_d_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localindex(1) < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err="Index not in the HALO") + goto 9999 + else + call x%set_entry(localindex(1),val) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_d_setelem + diff --git a/base/tools/psb_ssetelem.f90 b/base/tools/psb_ssetelem.f90 new file mode 100644 index 00000000..99247c77 --- /dev/null +++ b/base/tools/psb_ssetelem.f90 @@ -0,0 +1,112 @@ +! +! 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. +! +! Function: psb_s_setelem +! Set entries into a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_s_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +subroutine psb_s_setelem(index,val,x,desc_a,info) + use psb_base_mod, psb_protect_name => psb_s_setelem + use psi_mod + implicit none + + type(psb_s_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: val + + !locals + integer(psb_ipk_) :: localindex(1) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + info = 0 + + gindex(1) = index + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_s_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localindex(1) < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err="Index not in the HALO") + goto 9999 + else + call x%set_entry(localindex(1),val) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_s_setelem + diff --git a/base/tools/psb_zsetelem.f90 b/base/tools/psb_zsetelem.f90 new file mode 100644 index 00000000..abf25dc5 --- /dev/null +++ b/base/tools/psb_zsetelem.f90 @@ -0,0 +1,112 @@ +! +! 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. +! +! Function: psb_z_setelem +! Set entries into a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_z_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +subroutine psb_z_setelem(index,val,x,desc_a,info) + use psb_base_mod, psb_protect_name => psb_z_setelem + use psi_mod + implicit none + + type(psb_z_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: val + + !locals + integer(psb_ipk_) :: localindex(1) + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + info = 0 + + gindex(1) = index + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_z_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localindex(1) < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err="Index not in the HALO") + goto 9999 + else + call x%set_entry(localindex(1),val) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_z_setelem + diff --git a/cbind/base/psb_base_cbind_mod.f90 b/cbind/base/psb_base_cbind_mod.f90 index 036e662a..67d97aad 100644 --- a/cbind/base/psb_base_cbind_mod.f90 +++ b/cbind/base/psb_base_cbind_mod.f90 @@ -1,6 +1,10 @@ module psb_base_cbind_mod use psb_objhandle_mod use psb_cpenv_mod + use psb_s_serial_cbind_mod + use psb_d_serial_cbind_mod + use psb_c_serial_cbind_mod + use psb_z_serial_cbind_mod use psb_base_tools_cbind_mod use psb_s_tools_cbind_mod use psb_d_tools_cbind_mod diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index 45b6c825..c671dabd 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -40,6 +40,8 @@ psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_cgereinit(psb_c_cvector *xh, psb_c_descriptor *cdh, bool clear); psb_c_t psb_c_cgetelem(psb_c_cvector *xh,psb_l_t index,psb_c_descriptor *cd); psb_c_t psb_c_cmatgetelem(psb_c_cspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); +psb_i_t psb_c_csetelem(psb_l_t index, psb_c_t val, + psb_c_cvector *xh, psb_c_descriptor *cd); /* sparse matrices*/ psb_c_cspmat* psb_c_new_cspmat(); @@ -64,8 +66,12 @@ psb_i_t psb_c_cspasb_opt(psb_c_cspmat *mh, psb_c_descriptor *cdh, const char *afmt, psb_i_t upd, psb_i_t dupl); psb_i_t psb_c_csprn(psb_c_cspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_cmat_name_print(psb_c_cspmat *mh, char *name); -psb_i_t psb_c_cvect_set_scal(psb_c_cvector *xh, psb_c_t val); -psb_i_t psb_c_cvect_set_vect(psb_c_cvector *xh, psb_c_t *val, psb_i_t n); +psb_i_t psb_c_cvect_set_scal(psb_c_cvector *xh, psb_c_t val); +psb_i_t psb_c_cvect_set_scal_bound(psb_c_cvector *xh, psb_c_t val, + psb_i_t ifirst, psb_i_t ilast); +psb_i_t psb_c_cvect_set_vect(psb_c_cvector *xh, psb_c_t *val, psb_i_t n); +psb_c_t psb_c_cvect_get_entry(psb_c_cvector *xh, psb_i_t index); +psb_i_t psb_c_cvect_set_entry(psb_c_cvector *xh, psb_i_t index, psb_c_t val); /* psblas computational routines */ psb_c_t psb_c_cgedot(psb_c_cvector *xh, psb_c_cvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_ccomm.h b/cbind/base/psb_c_ccomm.h index dc45b4e9..ec620e96 100644 --- a/cbind/base/psb_c_ccomm.h +++ b/cbind/base/psb_c_ccomm.h @@ -12,13 +12,15 @@ extern "C" { psb_i_t psb_c_covrl(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_covrl_opt(psb_c_cvector *xh, psb_c_descriptor *cdh, psb_i_t update, psb_i_t mode); - psb_i_t psb_c_cvscatter(psb_l_t ng, psb_c_t *gx, psb_c_cvector *xh, psb_c_descriptor *cdh); + psb_i_t psb_c_cvscatter(psb_l_t ng, psb_c_t *gx, psb_c_cvector *xh, + psb_c_descriptor *cdh); psb_c_t* psb_c_cvgather(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_c_cspmat* psb_c_cspgather(psb_c_cspmat *ah, psb_c_descriptor *cdh); psb_i_t psb_c_cvgather_f(psb_c_t* gv, psb_c_cvector *xh, psb_c_descriptor *cdh); - psb_i_t psb_c_cspgather_f(psb_c_cspmat* ga, psb_c_cspmat *ah, psb_c_descriptor *cdh); + psb_i_t psb_c_cspgather_f(psb_c_cspmat* ga, psb_c_cspmat *ah, + psb_c_descriptor *cdh); #ifdef __cplusplus diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index bf0be8ba..d3c00744 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -23,7 +23,6 @@ psb_i_t psb_c_dvect_f_get_cpy(psb_d_t *v, psb_c_dvector *xh); psb_i_t psb_c_dvect_zero(psb_c_dvector *xh); psb_d_t *psb_c_dvect_f_get_pnt( psb_c_dvector *xh); psb_i_t psb_c_dvect_clone(psb_c_dvector *xh,psb_c_dvector *yh); - psb_i_t psb_c_dgeall(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgeall_remote(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgeall_remote_options(psb_c_dvector *xh, psb_c_descriptor *cdh, @@ -35,12 +34,15 @@ psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val, psb_i_t psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgeasb_options(psb_c_dvector *xh, psb_c_descriptor *cdh, psb_i_t dupl); psb_i_t psb_c_dgeasb_options_format(psb_c_dvector *xh, psb_c_descriptor *cdh, - psb_i_t dupl, const char *fmt); + psb_i_t dupl, const char *fmt); psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgereinit(psb_c_dvector *xh, psb_c_descriptor *cdh, bool clear); psb_d_t psb_c_dgetelem(psb_c_dvector *xh,psb_l_t index,psb_c_descriptor *cd); -psb_d_t psb_c_dmatgetelem(psb_c_dspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); - +psb_d_t psb_c_dmatgetelem(psb_c_dspmat *ah,psb_l_t rowindex, + psb_l_t colindex,psb_c_descriptor *cdh); +psb_d_t psb_c_dgetelem(psb_c_dvector *xh, psb_l_t index,psb_c_descriptor *cd); +psb_i_t psb_c_dsetelem(psb_l_t index, psb_d_t val, + psb_c_dvector *xh, psb_c_descriptor *cd); /* sparse matrices*/ psb_c_dspmat* psb_c_new_dspmat(); @@ -66,7 +68,11 @@ psb_i_t psb_c_dspasb_opt(psb_c_dspmat *mh, psb_c_descriptor *cdh, psb_i_t psb_c_dsprn(psb_c_dspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_dmat_name_print(psb_c_dspmat *mh, char *name); psb_i_t psb_c_dvect_set_scal(psb_c_dvector *xh, psb_d_t val); +psb_i_t psb_c_dvect_set_scal_bound(psb_c_dvector *xh, psb_d_t val, + psb_i_t ifirst, psb_i_t ilast); psb_i_t psb_c_dvect_set_vect(psb_c_dvector *xh, psb_d_t *val, psb_i_t n); +psb_d_t psb_c_dvect_get_entry(psb_c_dvector *xh, psb_i_t index); +psb_i_t psb_c_dvect_set_entry(psb_c_dvector *xh, psb_i_t index, psb_d_t val); /* psblas computational routines */ psb_d_t psb_c_dgedot(psb_c_dvector *xh, psb_c_dvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index fa501a50..abc96b2a 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -35,12 +35,14 @@ psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val, psb_i_t psb_c_sgeasb(psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgeasb_options(psb_c_svector *xh, psb_c_descriptor *cdh, psb_i_t dupl); psb_i_t psb_c_sgeasb_options_format(psb_c_svector *xh, psb_c_descriptor *cdh, - const char *fmt, psb_i_t dupl); + const char *fmt, psb_i_t dupl); psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgereinit(psb_c_svector *xh, psb_c_descriptor *cdh, bool clear); psb_s_t psb_c_sgetelem(psb_c_svector *xh,psb_l_t index,psb_c_descriptor *cd); -psb_s_t psb_c_smatgetelem(psb_c_sspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); - +psb_s_t psb_c_smatgetelem(psb_c_sspmat *ah,psb_l_t rowindex, + psb_l_t colindex,psb_c_descriptor *cdh); +psb_i_t psb_c_ssetelem(psb_l_t index, psb_s_t val, + psb_c_svector *xh, psb_c_descriptor *cd); /* sparse matrices*/ psb_c_sspmat* psb_c_new_sspmat(); @@ -66,7 +68,11 @@ psb_i_t psb_c_scopy_mat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_c_descriptor *cd psb_i_t psb_c_ssprn(psb_c_sspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_smat_name_print(psb_c_sspmat *mh, char *name); psb_i_t psb_c_svect_set_scal(psb_c_svector *xh, psb_s_t val); +psb_i_t psb_c_svect_set_scal_bound(psb_c_svector *xh, psb_s_t val, + psb_i_t ifirst, psb_i_t ilast); psb_i_t psb_c_svect_set_vect(psb_c_svector *xh, psb_s_t *val, psb_i_t n); +psb_s_t psb_c_svect_get_entry(psb_c_svector *xh, psb_i_t index); +psb_i_t psb_c_svect_set_entry(psb_c_svector *xh, psb_i_t index, psb_s_t val); /* psblas computational routines */ psb_s_t psb_c_sgedot(psb_c_svector *xh, psb_c_svector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index 805f4965..1ea736eb 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -176,6 +176,30 @@ contains end function psb_c_cvect_set_scal + function psb_c_cvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + complex(c_float_complex) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_cvect_set_scal_bound + function psb_c_cvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -200,6 +224,50 @@ contains end function psb_c_cvect_set_vect + function psb_c_cvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_float_complex), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_cvect_set_entry + + function psb_c_cvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + complex(c_float_complex) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_cvect_get_entry function psb_c_cvect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index 76849283..23c593c4 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -659,6 +659,42 @@ contains end function psb_c_cgetelem + function psb_c_csetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_cvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: val + integer(psb_c_ipk_) :: res + + type(psb_c_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_csetelem + function psb_c_cmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) implicit none @@ -666,7 +702,6 @@ contains integer(psb_c_lpk_), value :: rowindex, colindex type(psb_c_descriptor) :: cdh complex(c_float_complex) :: res - type(psb_cspmat_type), pointer :: ap type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info, ixb diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index fed51efb..235723b6 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -39,8 +39,10 @@ psb_i_t psb_c_zgeasb_options_format(psb_c_zvector *xh, psb_c_descriptor *cdh, psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zgereinit(psb_c_zvector *xh, psb_c_descriptor *cdh, bool clear); psb_z_t psb_c_zgetelem(psb_c_zvector *xh,psb_l_t index,psb_c_descriptor *cd); -psb_z_t psb_c_zmatgetelem(psb_c_zspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); - +psb_z_t psb_c_zmatgetelem(psb_c_zspmat *ah,psb_l_t rowindex, + psb_l_t colindex,psb_c_descriptor *cdh); +psb_i_t psb_c_zsetelem(psb_l_t index, psb_z_t val, + psb_c_zvector *xh, psb_c_descriptor *cd); /* sparse matrices*/ psb_c_zspmat* psb_c_new_zspmat(); @@ -67,7 +69,11 @@ psb_i_t psb_c_zspasb_opt(psb_c_zspmat *mh, psb_c_descriptor *cdh, psb_i_t psb_c_zsprn(psb_c_zspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_zmat_name_print(psb_c_zspmat *mh, char *name); psb_i_t psb_c_zvect_set_scal(psb_c_zvector *xh, psb_z_t val); +psb_i_t psb_c_zvect_set_scal_bound(psb_c_zvector *xh, psb_z_t val, + psb_i_t ifirst, psb_i_t ilast); psb_i_t psb_c_zvect_set_vect(psb_c_zvector *xh, psb_z_t *val, psb_i_t n); +psb_z_t psb_c_zvect_get_entry(psb_c_zvector *xh, psb_i_t index); +psb_i_t psb_c_zvect_set_entry(psb_c_zvector *xh, psb_i_t index, psb_z_t val); /* psblas computational routines */ psb_z_t psb_c_zgedot(psb_c_zvector *xh, psb_c_zvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index 04d840bd..6c9460a1 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -176,6 +176,30 @@ contains end function psb_c_dvect_set_scal + function psb_c_dvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + real(c_double) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_dvect_set_scal_bound + function psb_c_dvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -200,6 +224,50 @@ contains end function psb_c_dvect_set_vect + function psb_c_dvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_double), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_dvect_set_entry + + function psb_c_dvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + real(c_double) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_dvect_get_entry function psb_c_dvect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index daa28026..2dfd372b 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -669,6 +669,42 @@ contains end function psb_c_dgetelem + function psb_c_dsetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_dvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_double), value :: val + integer(psb_c_ipk_) :: res + + type(psb_d_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_dsetelem + function psb_c_dmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) implicit none @@ -676,7 +712,6 @@ contains integer(psb_c_lpk_), value :: rowindex, colindex type(psb_c_descriptor) :: cdh real(c_double) :: res - type(psb_dspmat_type), pointer :: ap type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info, ixb diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index e9f65bab..9fa7d308 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -176,6 +176,30 @@ contains end function psb_c_svect_set_scal + function psb_c_svect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + real(c_float) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_svect_set_scal_bound + function psb_c_svect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -200,6 +224,50 @@ contains end function psb_c_svect_set_vect + function psb_c_svect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_float), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_svect_set_entry + + function psb_c_svect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + real(c_float) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_svect_get_entry function psb_c_svect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index 2bc6b2d6..54951b21 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -669,6 +669,42 @@ contains end function psb_c_sgetelem + function psb_c_ssetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_svector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_float), value :: val + integer(psb_c_ipk_) :: res + + type(psb_s_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_ssetelem + function psb_c_smatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) implicit none @@ -676,7 +712,6 @@ contains integer(psb_c_lpk_), value :: rowindex, colindex type(psb_c_descriptor) :: cdh real(c_float) :: res - type(psb_sspmat_type), pointer :: ap type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info, ixb diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index fa3d7e12..d6fbd312 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -176,6 +176,30 @@ contains end function psb_c_zvect_set_scal + function psb_c_zvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + complex(c_double_complex) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_zvect_set_scal_bound + function psb_c_zvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -200,6 +224,50 @@ contains end function psb_c_zvect_set_vect + function psb_c_zvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_double_complex), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_zvect_set_entry + + function psb_c_zvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + complex(c_double_complex) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_zvect_get_entry function psb_c_zvect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index fe6c69b6..f37c6b68 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -659,6 +659,42 @@ contains end function psb_c_zgetelem + function psb_c_zsetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_zvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: val + integer(psb_c_ipk_) :: res + + type(psb_z_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_zsetelem + function psb_c_zmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) implicit none @@ -666,7 +702,6 @@ contains integer(psb_c_lpk_), value :: rowindex, colindex type(psb_c_descriptor) :: cdh complex(c_double_complex) :: res - type(psb_zspmat_type), pointer :: ap type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info, ixb diff --git a/cbind/linsolve/psb_linsolve_cbind.h b/cbind/linsolve/psb_linsolve_cbind.h index d1ed4a92..d86bf216 100644 --- a/cbind/linsolve/psb_linsolve_cbind.h +++ b/cbind/linsolve/psb_linsolve_cbind.h @@ -26,7 +26,7 @@ typedef struct psb_c_solveroptions { int psb_c_DefaultSolverOptions(psb_c_SolverOptions *opt); int psb_c_PrintSolverOptions(psb_c_SolverOptions *opt); - + int psb_c_skrylov(const char *method, psb_c_sspmat *ah, psb_c_sprec *ph, psb_c_svector *bh, psb_c_svector *xh, psb_c_descriptor *cdh, psb_c_SolverOptions *opt); diff --git a/configure b/configure index e8a214af..06ddfc66 100755 --- a/configure +++ b/configure @@ -4282,10 +4282,7 @@ _ACEOF break fi done - # aligned with autoconf, so not including core; see bug#72225. - rm -f -r a.out a.exe b.out conftest.$ac_ext conftest.$ac_objext \ - conftest.dSYM conftest1.$ac_ext conftest1.$ac_objext conftest1.dSYM \ - conftest2.$ac_ext conftest2.$ac_objext conftest2.dSYM + rm -f core conftest* unset am_i ;; esac fi @@ -5935,7 +5932,7 @@ else fi -am__api_version='1.18' +am__api_version='1.17' { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether sleep supports fractional seconds" >&5 printf %s "checking whether sleep supports fractional seconds... " >&6; } @@ -6104,14 +6101,10 @@ am_lf=' ' case `pwd` in *[\\\"\#\$\&\'\`$am_lf]*) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; esac case $srcdir in *[\\\"\#\$\&\'\`$am_lf\ \ ]*) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; esac @@ -6636,133 +6629,9 @@ AMTAR='$${TAR-tar}' # We'll loop over all known methods to create a tar archive until one works. -_am_tools='gnutar plaintar pax cpio none' - -# The POSIX 1988 'ustar' format is defined with fixed-size fields. - # There is notably a 21 bits limit for the UID and the GID. In fact, - # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343 - # and bug#13588). - am_max_uid=2097151 # 2^21 - 1 - am_max_gid=$am_max_uid - # The $UID and $GID variables are not portable, so we need to resort - # to the POSIX-mandated id(1) utility. Errors in the 'id' calls - # below are definitely unexpected, so allow the users to see them - # (that is, avoid stderr redirection). - am_uid=`id -u || echo unknown` - am_gid=`id -g || echo unknown` - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether UID '$am_uid' is supported by ustar format" >&5 -printf %s "checking whether UID '$am_uid' is supported by ustar format... " >&6; } - if test x$am_uid = xunknown; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ancient id detected; assuming current UID is ok, but dist-ustar might not work" >&5 -printf "%s\n" "$as_me: WARNING: ancient id detected; assuming current UID is ok, but dist-ustar might not work" >&2;} - elif test $am_uid -le $am_max_uid; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -printf "%s\n" "yes" >&6; } - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } - _am_tools=none - fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether GID '$am_gid' is supported by ustar format" >&5 -printf %s "checking whether GID '$am_gid' is supported by ustar format... " >&6; } - if test x$gm_gid = xunknown; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ancient id detected; assuming current GID is ok, but dist-ustar might not work" >&5 -printf "%s\n" "$as_me: WARNING: ancient id detected; assuming current GID is ok, but dist-ustar might not work" >&2;} - elif test $am_gid -le $am_max_gid; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -printf "%s\n" "yes" >&6; } - else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } - _am_tools=none - fi - - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to create a ustar tar archive" >&5 -printf %s "checking how to create a ustar tar archive... " >&6; } - - # Go ahead even if we have the value already cached. We do so because we - # need to set the values for the 'am__tar' and 'am__untar' variables. - _am_tools=${am_cv_prog_tar_ustar-$_am_tools} - - for _am_tool in $_am_tools; do - case $_am_tool in - gnutar) - for _am_tar in tar gnutar gtar; do - { echo "$as_me:$LINENO: $_am_tar --version" >&5 - ($_am_tar --version) >&5 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && break - done - am__tar="$_am_tar --format=ustar -chf - "'"$$tardir"' - am__tar_="$_am_tar --format=ustar -chf - "'"$tardir"' - am__untar="$_am_tar -xf -" - ;; - plaintar) - # Must skip GNU tar: if it does not support --format= it doesn't create - # ustar tarball either. - (tar --version) >/dev/null 2>&1 && continue - am__tar='tar chf - "$$tardir"' - am__tar_='tar chf - "$tardir"' - am__untar='tar xf -' - ;; - pax) - am__tar='pax -L -x ustar -w "$$tardir"' - am__tar_='pax -L -x ustar -w "$tardir"' - am__untar='pax -r' - ;; - cpio) - am__tar='find "$$tardir" -print | cpio -o -H ustar -L' - am__tar_='find "$tardir" -print | cpio -o -H ustar -L' - am__untar='cpio -i -H ustar -d' - ;; - none) - am__tar=false - am__tar_=false - am__untar=false - ;; - esac - - # If the value was cached, stop now. We just wanted to have am__tar - # and am__untar set. - test -n "${am_cv_prog_tar_ustar}" && break - - # tar/untar a dummy directory, and stop if the command works. - rm -rf conftest.dir - mkdir conftest.dir - echo GrepMe > conftest.dir/file - { echo "$as_me:$LINENO: tardir=conftest.dir && eval $am__tar_ >conftest.tar" >&5 - (tardir=conftest.dir && eval $am__tar_ >conftest.tar) >&5 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } - rm -rf conftest.dir - if test -s conftest.tar; then - { echo "$as_me:$LINENO: $am__untar &5 - ($am__untar &5 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } - { echo "$as_me:$LINENO: cat conftest.dir/file" >&5 - (cat conftest.dir/file) >&5 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } - grep GrepMe conftest.dir/file >/dev/null 2>&1 && break - fi - done - rm -rf conftest.dir - - if test ${am_cv_prog_tar_ustar+y} -then : - printf %s "(cached) " >&6 -else case e in #( - e) am_cv_prog_tar_ustar=$_am_tool ;; -esac -fi +_am_tools='gnutar pax cpio none' - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_tar_ustar" >&5 -printf "%s\n" "$am_cv_prog_tar_ustar" >&6; } +am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' @@ -9122,6 +8991,7 @@ else AR="$ac_cv_prog_AR" fi +AR="${AR} -cr" if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 @@ -9226,7 +9096,6 @@ else RANLIB="$ac_cv_prog_RANLIB" fi -AR="$AR -cr" ############################################################################### # BLAS library presence checks diff --git a/cuda/License-spgpu b/cuda/License-spgpu index 4e5e16f5..0c558951 100644 --- a/cuda/License-spgpu +++ b/cuda/License-spgpu @@ -1,26 +1,26 @@ - (C) Copyright 2011-2026 Davide Barbieri - (C) Copyright 2011-2026 Salvatore Filippone - - 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. Neither the of the copyright holder nor the names of its contributors - may 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. + (C) Copyright 2011-2026 Davide Barbieri + (C) Copyright 2011-2026 Salvatore Filippone + + 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. Neither the of the copyright holder nor the names of its contributors + may 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.