From ce6383b7ff01c24bb4770b64bbaeb85dba8749d4 Mon Sep 17 00:00:00 2001 From: cirdans-home Date: Wed, 20 Nov 2019 15:45:35 +0100 Subject: [PATCH] Added Element-by-Element divison --- base/modules/psblas/psb_c_psblas_mod.F90 | 11 + base/modules/psblas/psb_d_psblas_mod.F90 | 11 + base/modules/psblas/psb_s_psblas_mod.F90 | 11 + base/modules/psblas/psb_z_psblas_mod.F90 | 11 + base/modules/serial/psb_c_base_vect_mod.f90 | 800 +++++++++++--------- base/modules/serial/psb_c_vect_mod.F90 | 308 ++++---- base/modules/serial/psb_d_base_vect_mod.f90 | 800 +++++++++++--------- base/modules/serial/psb_d_vect_mod.F90 | 308 ++++---- base/modules/serial/psb_i_base_vect_mod.f90 | 509 +++++++------ base/modules/serial/psb_i_vect_mod.F90 | 152 ++-- base/modules/serial/psb_l_base_vect_mod.f90 | 509 +++++++------ base/modules/serial/psb_l_vect_mod.F90 | 152 ++-- base/modules/serial/psb_s_base_vect_mod.f90 | 800 +++++++++++--------- base/modules/serial/psb_s_vect_mod.F90 | 308 ++++---- base/modules/serial/psb_z_base_vect_mod.f90 | 800 +++++++++++--------- base/modules/serial/psb_z_vect_mod.F90 | 308 ++++---- base/psblas/Makefile | 11 +- base/psblas/psb_cdiv_vect.f90 | 105 +++ base/psblas/psb_ddiv_vect.f90 | 105 +++ base/psblas/psb_sdiv_vect.f90 | 105 +++ base/psblas/psb_zdiv_vect.f90 | 105 +++ test/kernel/vecoperation.f90 | 32 + 22 files changed, 3546 insertions(+), 2715 deletions(-) create mode 100644 base/psblas/psb_cdiv_vect.f90 create mode 100644 base/psblas/psb_ddiv_vect.f90 create mode 100644 base/psblas/psb_sdiv_vect.f90 create mode 100644 base/psblas/psb_zdiv_vect.f90 diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index f4d771e0..1e16312d 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -439,4 +439,15 @@ module psb_c_psblas_mod end subroutine psb_cmlt_vect end interface + interface psb_gediv + subroutine psb_cdiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cdiv_vect + end interface + end module psb_c_psblas_mod diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index 825fe41e..f7bdfa8f 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -439,4 +439,15 @@ module psb_d_psblas_mod end subroutine psb_dmlt_vect end interface + interface psb_gediv + subroutine psb_ddiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ddiv_vect + end interface + end module psb_d_psblas_mod diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index b91fad79..af2c17f6 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -439,4 +439,15 @@ module psb_s_psblas_mod end subroutine psb_smlt_vect end interface + interface psb_gediv + subroutine psb_sdiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sdiv_vect + end interface + end module psb_s_psblas_mod diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index afd0a9b7..807ec7cd 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -439,4 +439,15 @@ module psb_z_psblas_mod end subroutine psb_zmlt_vect end interface + interface psb_gediv + subroutine psb_zdiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zdiv_vect + end interface + end module psb_z_psblas_mod diff --git a/base/modules/serial/psb_c_base_vect_mod.f90 b/base/modules/serial/psb_c_base_vect_mod.f90 index 59f9816d..d9531474 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,14 +27,14 @@ ! 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 +! 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 @@ -43,7 +43,7 @@ ! ! module psb_c_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_c_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_c_base_vect_type - !! The psb_c_base_vect_type + !! The psb_c_base_vect_type !! defines a middle level complex(psb_spk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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 @@ -61,9 +61,9 @@ module psb_c_base_vect_mod !! sparse matrix types. !! type psb_c_base_vect_type - !> Values. + !> Values. complex(psb_spk_), allocatable :: v(:) - complex(psb_spk_), allocatable :: combuf(:) + complex(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_c_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => c_base_ins_a procedure, pass(x) :: ins_v => c_base_ins_v @@ -93,7 +93,7 @@ module psb_c_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => c_base_sync procedure, pass(x) :: is_host => c_base_is_host @@ -130,7 +130,7 @@ module psb_c_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => c_base_gthab procedure, pass(x) :: gthzv => c_base_gthzv @@ -164,6 +164,12 @@ module psb_c_base_vect_mod procedure, pass(z) :: mlt_av => c_base_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => c_base_div_v + procedure, pass(z) :: div_a2 => c_base_div_a2 + generic, public :: div => div_v, div_a2 + ! ! Scaling and norms ! procedure, pass(x) :: scal => c_base_scal @@ -183,11 +189,11 @@ module psb_c_base_vect_mod end interface psb_c_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +206,11 @@ contains 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. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +220,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +232,20 @@ contains !! subroutine c_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: this(:) class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine c_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +253,11 @@ contains !> Function bld_mn: !! \memberof psb_c_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine c_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +266,15 @@ contains call x%asb(n,info) 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. + !! \param n size to be allocated. !! subroutine c_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +283,24 @@ contains call x%asb(n,info) 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 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 + 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) - + end subroutine c_base_all !> Function base_mold: @@ -306,11 +312,11 @@ contains subroutine c_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -320,21 +326,21 @@ contains ! !> Function base_ins: !! \memberof psb_c_base_vect_type - !! \brief Insert coefficients. + !! \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 @@ -344,7 +350,7 @@ contains ! subroutine c_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +360,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -376,7 +382,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +400,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +409,7 @@ contains subroutine c_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +419,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + 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,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +442,14 @@ contains ! subroutine c_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=czero call x%set_host() end subroutine c_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +458,20 @@ contains !> Function base_asb: !! \memberof psb_c_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine c_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +488,20 @@ contains !> Function base_asb: !! \memberof psb_c_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine c_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +514,39 @@ contains !> Function base_free: !! \memberof psb_c_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine c_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine c_base_free - + ! !> Function base_free_buffer: !! \memberof psb_c_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine c_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +561,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine c_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +581,13 @@ contains !> Function base_free_comid: !! \memberof psb_c_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine c_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +599,77 @@ contains ! ! 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. - !! + !! ! subroutine c_base_sync(x) - implicit none + 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. - !! + !! ! subroutine c_base_set_host(x) - implicit none + 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. - !! + !! ! subroutine c_base_set_dev(x) - implicit none + 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. - !! + !! ! subroutine c_base_set_sync(x) - implicit none + 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 . - !! + !! ! function c_base_is_dev(x) result(res) - implicit none + 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 . - !! + !! ! function c_base_is_host(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +680,10 @@ contains !> Function base_is_sync !! \memberof psb_c_base_vect_type !! \brief Is vector on sync . - !! + !! ! function c_base_is_sync(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +692,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_c_base_vect_type !! \brief Number of entries - !! + !! ! function c_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +714,13 @@ contains !> Function base_get_sizeof !! \memberof psb_c_base_vect_type !! \brief Size in bytes - !! + !! ! function c_base_sizeof(x) result(res) - implicit none + 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() @@ -724,14 +730,14 @@ contains !> Function base_get_fmt !! \memberof psb_c_base_vect_type !! \brief Format - !! + !! ! function c_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function c_base_get_fmt - + ! ! @@ -740,7 +746,7 @@ contains !! \memberof psb_c_base_vect_type !! \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(:) @@ -748,21 +754,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + 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 + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function c_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +777,18 @@ contains !! \param val The value to set !! subroutine c_base_set_scal(x,val,first,last) - implicit none + 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_) :: info, first_, last_ 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() x%v(first_:last_) = val call x%set_host() @@ -794,14 +800,14 @@ contains !> Function base_set_vect !! \memberof psb_c_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine c_base_set_vect(x,val,first,last) - implicit none + 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_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +815,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +835,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine c_base_absval1(x) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +847,21 @@ contains end subroutine c_base_absval1 subroutine c_base_absval2(x,y) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x + 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 + 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 - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_c_base_vect_type @@ -864,12 +870,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function c_base_dot_v(n,x,y) result(res) - implicit none + 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. @@ -898,19 +904,19 @@ contains !! \param y(:) The array to be multiplied by !! function c_base_dot_a(n,x,y) result(res) - implicit none + 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. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +931,13 @@ contains !! subroutine c_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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) @@ -939,7 +945,7 @@ contains end subroutine c_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +959,20 @@ contains !! subroutine c_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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 - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +990,10 @@ contains !! subroutine c_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1011,7 @@ contains !! subroutine c_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:) class(psb_c_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1020,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1041,7 @@ contains !! subroutine c_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:) complex(psb_spk_), intent(in) :: x(:) @@ -1043,58 +1049,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + 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 + if (alpha == czero) then + if (beta == cone) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == cone) then - if (beta == czero) then - do i=1, n + if (alpha == cone) then + if (beta == czero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == cone) then - do i=1, n + else if (beta == cone) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + 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 - do i=1, n + else if (alpha == -cone) then + if (beta == czero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == cone) then - do i=1, n + else if (beta == cone) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == czero) then - do i=1, n + if (beta == czero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == cone) then - do i=1, n + else if (beta == cone) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1124,12 @@ contains subroutine c_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1139,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1154,12 @@ contains subroutine c_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1170,12 @@ contains subroutine c_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1183,57 @@ contains 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 + !! + 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 ! - ! Simple scaling + !> Function base_div_a2 + !! \memberof psb_c_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y + !! \param x(:) The array to be multiplied 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)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine c_base_div_a2 + + + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_c_base_vect_type @@ -1189,17 +1242,17 @@ contains !! subroutine c_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x complex(psb_spk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine c_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,28 +1261,28 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function c_base_nrm2(n,x) result(res) - implicit none + 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 function c_base_amax(n,x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) @@ -1241,17 +1294,17 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function c_base_asum(n,x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function c_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1319,18 @@ contains !! \param beta subroutine c_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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 @@ -1286,28 +1339,28 @@ contains !! \param idx(:) indices subroutine c_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,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. + ! New comm internals impl. ! subroutine c_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_c_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1373,22 @@ contains !> 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 - + 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 + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1398,7 @@ contains subroutine c_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1409,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_c_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1418,20 @@ contains !! \param idx(:) indices subroutine c_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_c_base_vect_type @@ -1387,14 +1440,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine c_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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() @@ -1403,12 +1456,12 @@ contains subroutine c_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n 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() @@ -1417,14 +1470,14 @@ contains subroutine c_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: beta class(psb_c_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1449,22 +1502,22 @@ module psb_c_base_multivect_mod use psb_c_base_vect_mod !> \namespace psb_base_mod \class psb_c_base_vect_type - !! The psb_c_base_vect_type + !! The psb_c_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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. !! - private + private public :: psb_c_base_multivect, psb_c_base_multivect_type type psb_c_base_multivect_type - !> Values. + !> Values. complex(psb_spk_), allocatable :: v(:,:) - complex(psb_spk_), allocatable :: combuf(:) + complex(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +1531,7 @@ module psb_c_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => c_base_mlv_ins procedure, pass(x) :: zero => c_base_mlv_zero @@ -1489,7 +1542,7 @@ module psb_c_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => c_base_mlv_sync procedure, pass(x) :: is_host => c_base_mlv_is_host @@ -1562,7 +1615,7 @@ module psb_c_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => c_base_mlv_gthab procedure, pass(x) :: gthzv => c_base_mlv_gthzv @@ -1584,7 +1637,7 @@ module psb_c_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +1656,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +1683,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +1698,7 @@ contains !> Function bld_n: !! \memberof psb_c_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine c_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +1715,13 @@ contains !! \memberof psb_c_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \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 + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +1739,7 @@ contains subroutine c_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -1700,21 +1753,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_c_base_multivect_type - !! \brief Insert coefficients. + !! \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 @@ -1724,7 +1777,7 @@ contains ! subroutine c_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +1787,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -1756,7 +1809,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +1826,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +1841,7 @@ contains ! subroutine c_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=czero @@ -1804,7 +1857,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_c_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +1866,7 @@ contains subroutine c_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +1883,20 @@ contains !> Function base_mlv_free: !! \memberof psb_c_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine c_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine c_base_mlv_free @@ -1853,15 +1906,15 @@ contains ! ! 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. - !! + !! ! subroutine c_base_mlv_sync(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_sync @@ -1870,10 +1923,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_c_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine c_base_mlv_set_host(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_set_host @@ -1882,10 +1935,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_c_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine c_base_mlv_set_dev(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_set_dev @@ -1894,10 +1947,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_c_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine c_base_mlv_set_sync(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_set_sync @@ -1906,10 +1959,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_c_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function c_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +1973,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_c_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function c_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +1987,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_c_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function c_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +1999,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_c_base_multivect_type !! \brief Number of entries - !! + !! ! function c_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2018,7 @@ contains end function c_base_mlv_get_nrows function c_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2031,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_c_base_multivect_type !! \brief Size in bytesa - !! + !! ! function c_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2047,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_c_base_multivect_type !! \brief Format - !! + !! ! function c_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function c_base_mlv_get_fmt @@ -2010,18 +2063,18 @@ contains !! \memberof psb_c_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function c_base_mlv_get_vect(x) result(res) - implicit none + 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 + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2082,7 @@ contains end function c_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2091,7 @@ contains !! \param val The value to set !! subroutine c_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val @@ -2051,16 +2104,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_c_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine c_base_mlv_set_vect(x,val) - implicit none + 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 + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2125,8 @@ contains end subroutine c_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_c_base_multivect_type @@ -2082,7 +2135,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function c_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_spk_), allocatable :: res(:) @@ -2094,7 +2147,7 @@ contains ! ! 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). + ! 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 ! @@ -2123,7 +2176,7 @@ contains !! \param y(:) The array to be multiplied by !! function c_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2194,7 @@ contains end function c_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2209,7 @@ contains !! subroutine c_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + 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 @@ -2180,7 +2233,7 @@ contains end subroutine c_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2247,7 @@ contains !! subroutine c_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent(in) :: x(:,:) class(psb_c_base_multivect_type), intent(inout) :: y @@ -2230,10 +2283,10 @@ contains !! subroutine c_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2296,10 @@ contains subroutine c_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2316,7 @@ contains !! subroutine c_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:) class(psb_c_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2324,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2339,7 @@ contains !! subroutine c_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:,:) class(psb_c_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2366,7 @@ contains !! subroutine c_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:,:) complex(psb_spk_), intent(in) :: x(:,:) @@ -2321,38 +2374,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 @@ -2373,12 +2426,12 @@ contains 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 + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +2442,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +2457,39 @@ contains !!$ !!$ subroutine c_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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 + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_c_base_multivect_type @@ -2445,7 +2498,7 @@ contains !! subroutine c_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent (in) :: alpha @@ -2462,7 +2515,7 @@ contains !! \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 + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2484,7 +2537,7 @@ contains !! \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 + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2505,7 +2558,7 @@ contains !! \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 + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2528,7 +2581,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine c_base_mlv_absval1(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +2593,13 @@ contains end subroutine c_base_mlv_absval1 subroutine c_base_mlv_absval2(x,y) - implicit none + 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 + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) call y%absval() end if @@ -2555,15 +2608,15 @@ contains function c_base_mlv_use_buffer() result(res) - implicit none + 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 + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +2628,7 @@ contains subroutine c_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +2639,12 @@ contains subroutine c_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +2652,7 @@ contains subroutine c_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +2662,7 @@ contains subroutine c_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +2685,7 @@ contains !! \param beta subroutine c_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: alpha, beta, y(:) class(psb_c_base_multivect_type) :: x @@ -2648,7 +2701,7 @@ contains 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 @@ -2657,7 +2710,7 @@ contains !! \param idx(:) indices subroutine c_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: y(:) @@ -2670,7 +2723,7 @@ contains ! ! 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 @@ -2679,7 +2732,7 @@ contains !! \param idx(:) indices subroutine c_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: y(:) class(psb_c_base_multivect_type) :: x @@ -2696,7 +2749,7 @@ contains 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 @@ -2705,7 +2758,7 @@ contains !! \param idx(:) indices subroutine c_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: y(:,:) class(psb_c_base_multivect_type) :: x @@ -2722,17 +2775,17 @@ contains end subroutine c_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine c_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_c_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +2797,9 @@ contains end subroutine c_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_c_base_multivect_type @@ -2755,10 +2808,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine c_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:) class(psb_c_base_multivect_type) :: y @@ -2773,7 +2826,7 @@ contains subroutine c_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:,:) class(psb_c_base_multivect_type) :: y @@ -2788,7 +2841,7 @@ contains subroutine c_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex( psb_spk_) :: beta, x(:) @@ -2800,14 +2853,14 @@ contains subroutine c_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n 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 + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +2869,18 @@ contains 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. - !! + !! ! subroutine c_base_mlv_device_wait() - implicit none - + implicit none + end subroutine c_base_mlv_device_wait 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 c7a9a074..02965a3c 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_c_vect_mod ! ! This module contains the definition of the psb_c_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_c_vect_mod @@ -43,7 +43,7 @@ module psb_c_vect_mod use psb_i_vect_mod type psb_c_vect_type - class(psb_c_base_vect_type), allocatable :: v + class(psb_c_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => c_vect_get_nrows procedure, pass(x) :: sizeof => c_vect_sizeof @@ -94,13 +94,16 @@ module psb_c_vect_mod procedure, pass(z) :: mlt_av => c_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => c_vect_div_v + procedure, pass(z) :: div_a2 => c_vect_div_a2 + generic, public :: div => div_v, div_a2 procedure, pass(x) :: scal => c_vect_scal procedure, pass(x) :: absval1 => c_vect_absval1 procedure, pass(x) :: absval2 => c_vect_absval2 generic, public :: absval => absval1, absval2 procedure, pass(x) :: nrm2 => c_vect_nrm2 procedure, pass(x) :: amax => c_vect_amax - procedure, pass(x) :: asum => c_vect_asum + procedure, pass(x) :: asum => c_vect_asum end type psb_c_vect_type public :: psb_c_vect @@ -122,7 +125,7 @@ module psb_c_vect_mod private :: c_vect_dot_v, c_vect_dot_a, c_vect_axpby_v, c_vect_axpby_a, & & c_vect_mlt_v, c_vect_mlt_a, c_vect_mlt_a_2, c_vect_mlt_v_2, & & c_vect_mlt_va, c_vect_mlt_av, c_vect_scal, c_vect_absval1, & - & c_vect_absval2, c_vect_nrm2, c_vect_amax, c_vect_asum + & c_vect_absval2, c_vect_nrm2, c_vect_amax, c_vect_asum @@ -141,11 +144,11 @@ module psb_c_vect_mod contains - subroutine psb_c_set_vect_default(v) - implicit none + subroutine psb_c_set_vect_default(v) + implicit none class(psb_c_base_vect_type), intent(in) :: v - if (allocated(psb_c_base_vect_default)) then + if (allocated(psb_c_base_vect_default)) then deallocate(psb_c_base_vect_default) end if allocate(psb_c_base_vect_default, mold=v) @@ -153,7 +156,7 @@ contains end subroutine psb_c_set_vect_default function psb_c_get_vect_default(v) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: v class(psb_c_base_vect_type), pointer :: res @@ -163,10 +166,10 @@ contains function psb_c_get_base_vect_default() result(res) - implicit none + implicit none class(psb_c_base_vect_type), pointer :: res - if (.not.allocated(psb_c_base_vect_default)) then + if (.not.allocated(psb_c_base_vect_default)) then allocate(psb_c_base_vect_type :: psb_c_base_vect_default) end if @@ -176,14 +179,14 @@ contains subroutine c_vect_clone(x,y,info) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine c_vect_clone @@ -198,7 +201,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) @@ -220,7 +223,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) @@ -241,7 +244,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) @@ -304,7 +307,7 @@ contains end function size_const function c_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -312,7 +315,7 @@ contains end function c_vect_get_nrows function c_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -320,7 +323,7 @@ contains end function c_vect_sizeof function c_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -329,7 +332,7 @@ contains subroutine c_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold @@ -338,12 +341,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_c_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -353,12 +356,12 @@ contains subroutine c_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -368,7 +371,7 @@ contains subroutine c_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -378,7 +381,7 @@ contains subroutine c_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -424,12 +427,12 @@ contains subroutine c_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -438,7 +441,7 @@ contains subroutine c_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -448,7 +451,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -459,7 +462,7 @@ contains subroutine c_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -469,7 +472,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -487,12 +490,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_c_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -503,7 +506,7 @@ contains subroutine c_vect_sync(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -512,7 +515,7 @@ contains end subroutine c_vect_sync subroutine c_vect_set_sync(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -521,7 +524,7 @@ contains end subroutine c_vect_set_sync subroutine c_vect_set_host(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -530,7 +533,7 @@ contains end subroutine c_vect_set_host subroutine c_vect_set_dev(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -539,7 +542,7 @@ contains end subroutine c_vect_set_dev function c_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x @@ -550,7 +553,7 @@ contains end function c_vect_is_sync function c_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x @@ -561,11 +564,11 @@ contains end function c_vect_is_host function c_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -573,7 +576,7 @@ contains function c_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_spk_) :: res @@ -585,7 +588,7 @@ contains end function c_vect_dot_v function c_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -599,14 +602,14 @@ contains subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -616,7 +619,7 @@ contains subroutine c_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent(in) :: x(:) class(psb_c_vect_type), intent(inout) :: y @@ -631,10 +634,10 @@ contains subroutine c_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -645,7 +648,7 @@ contains subroutine c_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:) class(psb_c_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -661,7 +664,7 @@ contains subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:) complex(psb_spk_), intent(in) :: x(:) @@ -669,7 +672,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -677,12 +680,12 @@ contains subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -696,12 +699,12 @@ contains subroutine c_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: x(:) class(psb_c_vect_type), intent(inout) :: y class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -712,12 +715,12 @@ contains subroutine c_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:) class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -727,9 +730,38 @@ contains end subroutine c_vect_mlt_va + subroutine c_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine c_vect_div_v + + subroutine c_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine c_vect_div_a2 + subroutine c_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x complex(psb_spk_), intent (in) :: alpha @@ -749,19 +781,19 @@ contains class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine c_vect_absval2 function c_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = szero @@ -770,12 +802,12 @@ contains end function c_vect_nrm2 function c_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = szero @@ -784,12 +816,12 @@ contains end function c_vect_amax function c_vect_asum(n,x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%asum(n) else res = szero @@ -812,7 +844,7 @@ module psb_c_multivect_mod !private type psb_c_multivect_type - class(psb_c_base_multivect_type), allocatable :: v + class(psb_c_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => c_vect_get_nrows procedure, pass(x) :: get_ncols => c_vect_get_ncols @@ -886,11 +918,11 @@ module psb_c_multivect_mod contains - subroutine psb_c_set_multivect_default(v) - implicit none + subroutine psb_c_set_multivect_default(v) + implicit none class(psb_c_base_multivect_type), intent(in) :: v - if (allocated(psb_c_base_multivect_default)) then + if (allocated(psb_c_base_multivect_default)) then deallocate(psb_c_base_multivect_default) end if allocate(psb_c_base_multivect_default, mold=v) @@ -898,7 +930,7 @@ contains end subroutine psb_c_set_multivect_default function psb_c_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: v class(psb_c_base_multivect_type), pointer :: res @@ -908,10 +940,10 @@ contains function psb_c_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_c_base_multivect_type), pointer :: res - if (.not.allocated(psb_c_base_multivect_default)) then + if (.not.allocated(psb_c_base_multivect_default)) then allocate(psb_c_base_multivect_type :: psb_c_base_multivect_default) end if @@ -921,14 +953,14 @@ contains subroutine c_vect_clone(x,y,info) - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x class(psb_c_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine c_vect_clone @@ -941,7 +973,7 @@ contains class(psb_c_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) @@ -959,7 +991,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) @@ -1019,7 +1051,7 @@ contains end function size_const function c_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1027,7 +1059,7 @@ contains end function c_vect_get_nrows function c_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1035,7 +1067,7 @@ contains end function c_vect_get_ncols function c_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1043,7 +1075,7 @@ contains end function c_vect_sizeof function c_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1052,18 +1084,18 @@ contains subroutine c_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(out) :: x class(psb_c_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_c_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1073,12 +1105,12 @@ contains subroutine c_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1088,7 +1120,7 @@ contains subroutine c_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1098,7 +1130,7 @@ contains subroutine c_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1109,7 +1141,7 @@ contains end subroutine c_vect_asb subroutine c_vect_sync(x) - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1177,12 +1209,12 @@ contains subroutine c_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1191,7 +1223,7 @@ contains subroutine c_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1201,7 +1233,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1217,12 +1249,12 @@ contains class(psb_c_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_c_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1232,7 +1264,7 @@ contains !!$ function c_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_spk_) :: res @@ -1244,28 +1276,28 @@ contains !!$ end function c_vect_dot_v !!$ !!$ function c_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ complex(psb_spk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_spk_) :: res -!!$ +!!$ !!$ res = czero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function c_vect_dot_a -!!$ +!!$ !!$ subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ complex(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1275,25 +1307,25 @@ contains !!$ !!$ subroutine c_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ complex(psb_spk_), intent(in) :: x(:) !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ complex(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine c_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine c_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1304,7 +1336,7 @@ contains !!$ !!$ subroutine c_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: x(:) !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1314,13 +1346,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine c_vect_mlt_a !!$ !!$ !!$ subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: y(:) !!$ complex(psb_spk_), intent(in) :: x(:) @@ -1328,20 +1360,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine c_vect_mlt_a_2 !!$ !!$ subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ class(psb_c_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1355,12 +1387,12 @@ contains !!$ !!$ subroutine c_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: x(:) !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ class(psb_c_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1371,16 +1403,16 @@ contains !!$ !!$ subroutine c_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: y(:) !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1388,36 +1420,36 @@ contains !!$ !!$ subroutine c_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ complex(psb_spk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine c_vect_scal !!$ !!$ !!$ function c_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = szero !!$ end if !!$ !!$ end function c_vect_nrm2 -!!$ +!!$ !!$ function c_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = szero @@ -1426,12 +1458,12 @@ contains !!$ end function c_vect_amax !!$ !!$ function c_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = szero diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 8a59b513..4d3bb161 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,14 +27,14 @@ ! 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 +! 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 @@ -43,7 +43,7 @@ ! ! module psb_d_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_d_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_d_base_vect_type - !! The psb_d_base_vect_type + !! The psb_d_base_vect_type !! defines a middle level real(psb_dpk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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 @@ -61,9 +61,9 @@ module psb_d_base_vect_mod !! sparse matrix types. !! type psb_d_base_vect_type - !> Values. + !> Values. real(psb_dpk_), allocatable :: v(:) - real(psb_dpk_), allocatable :: combuf(:) + real(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_d_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => d_base_ins_a procedure, pass(x) :: ins_v => d_base_ins_v @@ -93,7 +93,7 @@ module psb_d_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => d_base_sync procedure, pass(x) :: is_host => d_base_is_host @@ -130,7 +130,7 @@ module psb_d_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => d_base_gthab procedure, pass(x) :: gthzv => d_base_gthzv @@ -164,6 +164,12 @@ module psb_d_base_vect_mod procedure, pass(z) :: mlt_av => d_base_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => d_base_div_v + procedure, pass(z) :: div_a2 => d_base_div_a2 + generic, public :: div => div_v, div_a2 + ! ! Scaling and norms ! procedure, pass(x) :: scal => d_base_scal @@ -183,11 +189,11 @@ module psb_d_base_vect_mod end interface psb_d_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +206,11 @@ contains 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. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +220,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +232,20 @@ contains !! subroutine d_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: this(:) class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine d_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +253,11 @@ contains !> Function bld_mn: !! \memberof psb_d_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine d_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +266,15 @@ contains call x%asb(n,info) 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. + !! \param n size to be allocated. !! subroutine d_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +283,24 @@ contains call x%asb(n,info) 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 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 + 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) - + end subroutine d_base_all !> Function base_mold: @@ -306,11 +312,11 @@ contains subroutine d_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -320,21 +326,21 @@ contains ! !> Function base_ins: !! \memberof psb_d_base_vect_type - !! \brief Insert coefficients. + !! \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 @@ -344,7 +350,7 @@ contains ! subroutine d_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +360,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -376,7 +382,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +400,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +409,7 @@ contains subroutine d_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +419,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + 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,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +442,14 @@ contains ! subroutine d_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=dzero call x%set_host() end subroutine d_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +458,20 @@ contains !> Function base_asb: !! \memberof psb_d_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine d_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +488,20 @@ contains !> Function base_asb: !! \memberof psb_d_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine d_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +514,39 @@ contains !> Function base_free: !! \memberof psb_d_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine d_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine d_base_free - + ! !> Function base_free_buffer: !! \memberof psb_d_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine d_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +561,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine d_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +581,13 @@ contains !> Function base_free_comid: !! \memberof psb_d_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine d_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +599,77 @@ contains ! ! 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. - !! + !! ! subroutine d_base_sync(x) - implicit none + 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. - !! + !! ! subroutine d_base_set_host(x) - implicit none + 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. - !! + !! ! subroutine d_base_set_dev(x) - implicit none + 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. - !! + !! ! subroutine d_base_set_sync(x) - implicit none + 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 . - !! + !! ! function d_base_is_dev(x) result(res) - implicit none + 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 . - !! + !! ! function d_base_is_host(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +680,10 @@ contains !> Function base_is_sync !! \memberof psb_d_base_vect_type !! \brief Is vector on sync . - !! + !! ! function d_base_is_sync(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +692,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_d_base_vect_type !! \brief Number of entries - !! + !! ! function d_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +714,13 @@ contains !> Function base_get_sizeof !! \memberof psb_d_base_vect_type !! \brief Size in bytes - !! + !! ! function d_base_sizeof(x) result(res) - implicit none + 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() @@ -724,14 +730,14 @@ contains !> Function base_get_fmt !! \memberof psb_d_base_vect_type !! \brief Format - !! + !! ! function d_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function d_base_get_fmt - + ! ! @@ -740,7 +746,7 @@ contains !! \memberof psb_d_base_vect_type !! \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(:) @@ -748,21 +754,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + 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 + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function d_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +777,18 @@ contains !! \param val The value to set !! subroutine d_base_set_scal(x,val,first,last) - implicit none + 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_) :: info, first_, last_ 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() x%v(first_:last_) = val call x%set_host() @@ -794,14 +800,14 @@ contains !> Function base_set_vect !! \memberof psb_d_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine d_base_set_vect(x,val,first,last) - implicit none + 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_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +815,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +835,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine d_base_absval1(x) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +847,21 @@ contains end subroutine d_base_absval1 subroutine d_base_absval2(x,y) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x + 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 + 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 - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_d_base_vect_type @@ -864,12 +870,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function d_base_dot_v(n,x,y) result(res) - implicit none + 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. @@ -898,19 +904,19 @@ contains !! \param y(:) The array to be multiplied by !! function d_base_dot_a(n,x,y) result(res) - implicit none + 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. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +931,13 @@ contains !! subroutine d_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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) @@ -939,7 +945,7 @@ contains end subroutine d_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +959,20 @@ contains !! subroutine d_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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 - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +990,10 @@ contains !! subroutine d_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1011,7 @@ contains !! subroutine d_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:) class(psb_d_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1020,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1041,7 @@ contains !! subroutine d_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:) real(psb_dpk_), intent(in) :: x(:) @@ -1043,58 +1049,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + 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 + if (alpha == dzero) then + if (beta == done) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == done) then - if (beta == dzero) then - do i=1, n + if (alpha == done) then + if (beta == dzero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == done) then - do i=1, n + else if (beta == done) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + 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 - do i=1, n + else if (alpha == -done) then + if (beta == dzero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == done) then - do i=1, n + else if (beta == done) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == dzero) then - do i=1, n + if (beta == dzero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == done) then - do i=1, n + else if (beta == done) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1124,12 @@ contains subroutine d_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1139,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1154,12 @@ contains subroutine d_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1170,12 @@ contains subroutine d_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1183,57 @@ contains 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 + !! + 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 ! - ! Simple scaling + !> Function base_div_a2 + !! \memberof psb_d_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y + !! \param x(:) The array to be multiplied 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)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine d_base_div_a2 + + + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_d_base_vect_type @@ -1189,17 +1242,17 @@ contains !! subroutine d_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x real(psb_dpk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine d_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,28 +1261,28 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function d_base_nrm2(n,x) result(res) - implicit none + 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 function d_base_amax(n,x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) @@ -1241,17 +1294,17 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function d_base_asum(n,x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function d_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1319,18 @@ contains !! \param beta subroutine d_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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 @@ -1286,28 +1339,28 @@ contains !! \param idx(:) indices subroutine d_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,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. + ! New comm internals impl. ! subroutine d_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_d_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1373,22 @@ contains !> 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 - + 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 + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1398,7 @@ contains subroutine d_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1409,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_d_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1418,20 @@ contains !! \param idx(:) indices subroutine d_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_d_base_vect_type @@ -1387,14 +1440,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine d_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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() @@ -1403,12 +1456,12 @@ contains subroutine d_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n 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() @@ -1417,14 +1470,14 @@ contains subroutine d_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: beta class(psb_d_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1449,22 +1502,22 @@ module psb_d_base_multivect_mod use psb_d_base_vect_mod !> \namespace psb_base_mod \class psb_d_base_vect_type - !! The psb_d_base_vect_type + !! The psb_d_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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. !! - private + private public :: psb_d_base_multivect, psb_d_base_multivect_type type psb_d_base_multivect_type - !> Values. + !> Values. real(psb_dpk_), allocatable :: v(:,:) - real(psb_dpk_), allocatable :: combuf(:) + real(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +1531,7 @@ module psb_d_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => d_base_mlv_ins procedure, pass(x) :: zero => d_base_mlv_zero @@ -1489,7 +1542,7 @@ module psb_d_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => d_base_mlv_sync procedure, pass(x) :: is_host => d_base_mlv_is_host @@ -1562,7 +1615,7 @@ module psb_d_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => d_base_mlv_gthab procedure, pass(x) :: gthzv => d_base_mlv_gthzv @@ -1584,7 +1637,7 @@ module psb_d_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +1656,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +1683,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +1698,7 @@ contains !> Function bld_n: !! \memberof psb_d_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine d_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +1715,13 @@ contains !! \memberof psb_d_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \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 + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +1739,7 @@ contains subroutine d_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -1700,21 +1753,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_d_base_multivect_type - !! \brief Insert coefficients. + !! \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 @@ -1724,7 +1777,7 @@ contains ! subroutine d_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +1787,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -1756,7 +1809,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +1826,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +1841,7 @@ contains ! subroutine d_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=dzero @@ -1804,7 +1857,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_d_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +1866,7 @@ contains subroutine d_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +1883,20 @@ contains !> Function base_mlv_free: !! \memberof psb_d_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine d_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine d_base_mlv_free @@ -1853,15 +1906,15 @@ contains ! ! 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. - !! + !! ! subroutine d_base_mlv_sync(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_sync @@ -1870,10 +1923,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_d_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine d_base_mlv_set_host(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_set_host @@ -1882,10 +1935,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_d_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine d_base_mlv_set_dev(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_set_dev @@ -1894,10 +1947,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_d_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine d_base_mlv_set_sync(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_set_sync @@ -1906,10 +1959,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_d_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function d_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +1973,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_d_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function d_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +1987,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_d_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function d_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +1999,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_d_base_multivect_type !! \brief Number of entries - !! + !! ! function d_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2018,7 @@ contains end function d_base_mlv_get_nrows function d_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2031,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_d_base_multivect_type !! \brief Size in bytesa - !! + !! ! function d_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2047,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_d_base_multivect_type !! \brief Format - !! + !! ! function d_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function d_base_mlv_get_fmt @@ -2010,18 +2063,18 @@ contains !! \memberof psb_d_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function d_base_mlv_get_vect(x) result(res) - implicit none + 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 + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2082,7 @@ contains end function d_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2091,7 @@ contains !! \param val The value to set !! subroutine d_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val @@ -2051,16 +2104,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_d_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine d_base_mlv_set_vect(x,val) - implicit none + 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 + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2125,8 @@ contains end subroutine d_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_d_base_multivect_type @@ -2082,7 +2135,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function d_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2094,7 +2147,7 @@ contains ! ! 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). + ! 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 ! @@ -2123,7 +2176,7 @@ contains !! \param y(:) The array to be multiplied by !! function d_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2194,7 @@ contains end function d_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2209,7 @@ contains !! subroutine d_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + 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 @@ -2180,7 +2233,7 @@ contains end subroutine d_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2247,7 @@ contains !! subroutine d_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent(in) :: x(:,:) class(psb_d_base_multivect_type), intent(inout) :: y @@ -2230,10 +2283,10 @@ contains !! subroutine d_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2296,10 @@ contains subroutine d_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2316,7 @@ contains !! subroutine d_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:) class(psb_d_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2324,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2339,7 @@ contains !! subroutine d_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:,:) class(psb_d_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2366,7 @@ contains !! subroutine d_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:,:) real(psb_dpk_), intent(in) :: x(:,:) @@ -2321,38 +2374,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 @@ -2373,12 +2426,12 @@ contains 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 + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +2442,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +2457,39 @@ contains !!$ !!$ subroutine d_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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 + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_d_base_multivect_type @@ -2445,7 +2498,7 @@ contains !! subroutine d_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent (in) :: alpha @@ -2462,7 +2515,7 @@ contains !! \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 + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2484,7 +2537,7 @@ contains !! \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 + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2505,7 +2558,7 @@ contains !! \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 + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2528,7 +2581,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine d_base_mlv_absval1(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +2593,13 @@ contains end subroutine d_base_mlv_absval1 subroutine d_base_mlv_absval2(x,y) - implicit none + 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 + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) call y%absval() end if @@ -2555,15 +2608,15 @@ contains function d_base_mlv_use_buffer() result(res) - implicit none + 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 + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +2628,7 @@ contains subroutine d_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +2639,12 @@ contains subroutine d_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +2652,7 @@ contains subroutine d_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +2662,7 @@ contains subroutine d_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +2685,7 @@ contains !! \param beta subroutine d_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: alpha, beta, y(:) class(psb_d_base_multivect_type) :: x @@ -2648,7 +2701,7 @@ contains 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 @@ -2657,7 +2710,7 @@ contains !! \param idx(:) indices subroutine d_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: y(:) @@ -2670,7 +2723,7 @@ contains ! ! 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 @@ -2679,7 +2732,7 @@ contains !! \param idx(:) indices subroutine d_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: y(:) class(psb_d_base_multivect_type) :: x @@ -2696,7 +2749,7 @@ contains 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 @@ -2705,7 +2758,7 @@ contains !! \param idx(:) indices subroutine d_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: y(:,:) class(psb_d_base_multivect_type) :: x @@ -2722,17 +2775,17 @@ contains end subroutine d_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine d_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_d_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +2797,9 @@ contains end subroutine d_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_d_base_multivect_type @@ -2755,10 +2808,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine d_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:) class(psb_d_base_multivect_type) :: y @@ -2773,7 +2826,7 @@ contains subroutine d_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:,:) class(psb_d_base_multivect_type) :: y @@ -2788,7 +2841,7 @@ contains subroutine d_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real( psb_dpk_) :: beta, x(:) @@ -2800,14 +2853,14 @@ contains subroutine d_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n 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 + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +2869,18 @@ contains 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. - !! + !! ! subroutine d_base_mlv_device_wait() - implicit none - + implicit none + end subroutine d_base_mlv_device_wait 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 f6244e3e..469cb56d 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_d_vect_mod ! ! This module contains the definition of the psb_d_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_d_vect_mod @@ -43,7 +43,7 @@ module psb_d_vect_mod use psb_i_vect_mod type psb_d_vect_type - class(psb_d_base_vect_type), allocatable :: v + class(psb_d_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => d_vect_get_nrows procedure, pass(x) :: sizeof => d_vect_sizeof @@ -94,13 +94,16 @@ module psb_d_vect_mod procedure, pass(z) :: mlt_av => d_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => d_vect_div_v + procedure, pass(z) :: div_a2 => d_vect_div_a2 + generic, public :: div => div_v, div_a2 procedure, pass(x) :: scal => d_vect_scal procedure, pass(x) :: absval1 => d_vect_absval1 procedure, pass(x) :: absval2 => d_vect_absval2 generic, public :: absval => absval1, absval2 procedure, pass(x) :: nrm2 => d_vect_nrm2 procedure, pass(x) :: amax => d_vect_amax - procedure, pass(x) :: asum => d_vect_asum + procedure, pass(x) :: asum => d_vect_asum end type psb_d_vect_type public :: psb_d_vect @@ -122,7 +125,7 @@ module psb_d_vect_mod private :: d_vect_dot_v, d_vect_dot_a, d_vect_axpby_v, d_vect_axpby_a, & & d_vect_mlt_v, d_vect_mlt_a, d_vect_mlt_a_2, d_vect_mlt_v_2, & & d_vect_mlt_va, d_vect_mlt_av, d_vect_scal, d_vect_absval1, & - & d_vect_absval2, d_vect_nrm2, d_vect_amax, d_vect_asum + & d_vect_absval2, d_vect_nrm2, d_vect_amax, d_vect_asum @@ -141,11 +144,11 @@ module psb_d_vect_mod contains - subroutine psb_d_set_vect_default(v) - implicit none + subroutine psb_d_set_vect_default(v) + implicit none class(psb_d_base_vect_type), intent(in) :: v - if (allocated(psb_d_base_vect_default)) then + if (allocated(psb_d_base_vect_default)) then deallocate(psb_d_base_vect_default) end if allocate(psb_d_base_vect_default, mold=v) @@ -153,7 +156,7 @@ contains end subroutine psb_d_set_vect_default function psb_d_get_vect_default(v) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: v class(psb_d_base_vect_type), pointer :: res @@ -163,10 +166,10 @@ contains function psb_d_get_base_vect_default() result(res) - implicit none + implicit none class(psb_d_base_vect_type), pointer :: res - if (.not.allocated(psb_d_base_vect_default)) then + if (.not.allocated(psb_d_base_vect_default)) then allocate(psb_d_base_vect_type :: psb_d_base_vect_default) end if @@ -176,14 +179,14 @@ contains subroutine d_vect_clone(x,y,info) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine d_vect_clone @@ -198,7 +201,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) @@ -220,7 +223,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) @@ -241,7 +244,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) @@ -304,7 +307,7 @@ contains end function size_const function d_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -312,7 +315,7 @@ contains end function d_vect_get_nrows function d_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -320,7 +323,7 @@ contains end function d_vect_sizeof function d_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -329,7 +332,7 @@ contains subroutine d_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold @@ -338,12 +341,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_d_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -353,12 +356,12 @@ contains subroutine d_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -368,7 +371,7 @@ contains subroutine d_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -378,7 +381,7 @@ contains subroutine d_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -424,12 +427,12 @@ contains subroutine d_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -438,7 +441,7 @@ contains subroutine d_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -448,7 +451,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -459,7 +462,7 @@ contains subroutine d_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -469,7 +472,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -487,12 +490,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_d_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -503,7 +506,7 @@ contains subroutine d_vect_sync(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -512,7 +515,7 @@ contains end subroutine d_vect_sync subroutine d_vect_set_sync(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -521,7 +524,7 @@ contains end subroutine d_vect_set_sync subroutine d_vect_set_host(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -530,7 +533,7 @@ contains end subroutine d_vect_set_host subroutine d_vect_set_dev(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -539,7 +542,7 @@ contains end subroutine d_vect_set_dev function d_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x @@ -550,7 +553,7 @@ contains end function d_vect_is_sync function d_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x @@ -561,11 +564,11 @@ contains end function d_vect_is_host function d_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -573,7 +576,7 @@ contains function d_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res @@ -585,7 +588,7 @@ contains end function d_vect_dot_v function d_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -599,14 +602,14 @@ contains subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -616,7 +619,7 @@ contains subroutine d_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent(in) :: x(:) class(psb_d_vect_type), intent(inout) :: y @@ -631,10 +634,10 @@ contains subroutine d_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -645,7 +648,7 @@ contains subroutine d_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:) class(psb_d_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -661,7 +664,7 @@ contains subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:) real(psb_dpk_), intent(in) :: x(:) @@ -669,7 +672,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -677,12 +680,12 @@ contains subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -696,12 +699,12 @@ contains subroutine d_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: x(:) class(psb_d_vect_type), intent(inout) :: y class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -712,12 +715,12 @@ contains subroutine d_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:) class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -727,9 +730,38 @@ contains end subroutine d_vect_mlt_va + subroutine d_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine d_vect_div_v + + subroutine d_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine d_vect_div_a2 + subroutine d_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent (in) :: alpha @@ -749,19 +781,19 @@ contains class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine d_vect_absval2 function d_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = dzero @@ -770,12 +802,12 @@ contains end function d_vect_nrm2 function d_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = dzero @@ -784,12 +816,12 @@ contains end function d_vect_amax function d_vect_asum(n,x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%asum(n) else res = dzero @@ -812,7 +844,7 @@ module psb_d_multivect_mod !private type psb_d_multivect_type - class(psb_d_base_multivect_type), allocatable :: v + class(psb_d_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => d_vect_get_nrows procedure, pass(x) :: get_ncols => d_vect_get_ncols @@ -886,11 +918,11 @@ module psb_d_multivect_mod contains - subroutine psb_d_set_multivect_default(v) - implicit none + subroutine psb_d_set_multivect_default(v) + implicit none class(psb_d_base_multivect_type), intent(in) :: v - if (allocated(psb_d_base_multivect_default)) then + if (allocated(psb_d_base_multivect_default)) then deallocate(psb_d_base_multivect_default) end if allocate(psb_d_base_multivect_default, mold=v) @@ -898,7 +930,7 @@ contains end subroutine psb_d_set_multivect_default function psb_d_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: v class(psb_d_base_multivect_type), pointer :: res @@ -908,10 +940,10 @@ contains function psb_d_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_d_base_multivect_type), pointer :: res - if (.not.allocated(psb_d_base_multivect_default)) then + if (.not.allocated(psb_d_base_multivect_default)) then allocate(psb_d_base_multivect_type :: psb_d_base_multivect_default) end if @@ -921,14 +953,14 @@ contains subroutine d_vect_clone(x,y,info) - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x class(psb_d_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine d_vect_clone @@ -941,7 +973,7 @@ contains class(psb_d_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) @@ -959,7 +991,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) @@ -1019,7 +1051,7 @@ contains end function size_const function d_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1027,7 +1059,7 @@ contains end function d_vect_get_nrows function d_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1035,7 +1067,7 @@ contains end function d_vect_get_ncols function d_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1043,7 +1075,7 @@ contains end function d_vect_sizeof function d_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1052,18 +1084,18 @@ contains subroutine d_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(out) :: x class(psb_d_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_d_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1073,12 +1105,12 @@ contains subroutine d_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1088,7 +1120,7 @@ contains subroutine d_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1098,7 +1130,7 @@ contains subroutine d_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1109,7 +1141,7 @@ contains end subroutine d_vect_asb subroutine d_vect_sync(x) - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1177,12 +1209,12 @@ contains subroutine d_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1191,7 +1223,7 @@ contains subroutine d_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1201,7 +1233,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1217,12 +1249,12 @@ contains class(psb_d_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_d_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1232,7 +1264,7 @@ contains !!$ function d_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res @@ -1244,28 +1276,28 @@ contains !!$ end function d_vect_dot_v !!$ !!$ function d_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ real(psb_dpk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res -!!$ +!!$ !!$ res = dzero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function d_vect_dot_a -!!$ +!!$ !!$ subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ real(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1275,25 +1307,25 @@ contains !!$ !!$ subroutine d_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ real(psb_dpk_), intent(in) :: x(:) !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ real(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine d_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine d_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1304,7 +1336,7 @@ contains !!$ !!$ subroutine d_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: x(:) !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1314,13 +1346,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine d_vect_mlt_a !!$ !!$ !!$ subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: y(:) !!$ real(psb_dpk_), intent(in) :: x(:) @@ -1328,20 +1360,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine d_vect_mlt_a_2 !!$ !!$ subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ class(psb_d_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1355,12 +1387,12 @@ contains !!$ !!$ subroutine d_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: x(:) !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ class(psb_d_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1371,16 +1403,16 @@ contains !!$ !!$ subroutine d_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: y(:) !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1388,36 +1420,36 @@ contains !!$ !!$ subroutine d_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ real(psb_dpk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine d_vect_scal !!$ !!$ !!$ function d_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = dzero !!$ end if !!$ !!$ end function d_vect_nrm2 -!!$ +!!$ !!$ function d_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = dzero @@ -1426,12 +1458,12 @@ contains !!$ end function d_vect_amax !!$ !!$ function d_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = dzero diff --git a/base/modules/serial/psb_i_base_vect_mod.f90 b/base/modules/serial/psb_i_base_vect_mod.f90 index c1890931..06871cb4 100644 --- a/base/modules/serial/psb_i_base_vect_mod.f90 +++ b/base/modules/serial/psb_i_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,14 +27,14 @@ ! 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 +! 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 @@ -43,15 +43,15 @@ ! ! module psb_i_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod !> \namespace psb_base_mod \class psb_i_base_vect_type - !! The psb_i_base_vect_type + !! The psb_i_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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 @@ -59,9 +59,9 @@ module psb_i_base_vect_mod !! sparse matrix types. !! type psb_i_base_vect_type - !> Values. + !> Values. integer(psb_ipk_), allocatable :: v(:) - integer(psb_ipk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -76,7 +76,7 @@ module psb_i_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => i_base_ins_a procedure, pass(x) :: ins_v => i_base_ins_v @@ -91,7 +91,7 @@ module psb_i_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => i_base_sync procedure, pass(x) :: is_host => i_base_is_host @@ -128,7 +128,7 @@ module psb_i_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => i_base_gthab procedure, pass(x) :: gthzv => i_base_gthzv @@ -151,11 +151,11 @@ module psb_i_base_vect_mod end interface psb_i_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -168,11 +168,11 @@ contains 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. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -182,7 +182,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -194,20 +194,20 @@ contains !! subroutine i_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: this(:) class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine i_base_bld_x - + ! ! Create with size, but no initialization ! @@ -215,11 +215,11 @@ contains !> Function bld_mn: !! \memberof psb_i_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine i_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -228,15 +228,15 @@ contains call x%asb(n,info) 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. + !! \param n size to be allocated. !! subroutine i_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -245,24 +245,24 @@ contains call x%asb(n,info) 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 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 + 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) - + end subroutine i_base_all !> Function base_mold: @@ -274,11 +274,11 @@ contains subroutine i_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -288,21 +288,21 @@ contains ! !> Function base_ins: !! \memberof psb_i_base_vect_type - !! \brief Insert coefficients. + !! \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 @@ -312,7 +312,7 @@ contains ! subroutine i_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -322,21 +322,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -344,7 +344,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -362,7 +362,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -371,7 +371,7 @@ contains subroutine i_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -381,14 +381,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + 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,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -404,14 +404,14 @@ contains ! subroutine i_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=izero call x%set_host() end subroutine i_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -420,20 +420,20 @@ contains !> Function base_asb: !! \memberof psb_i_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine i_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -450,20 +450,20 @@ contains !> Function base_asb: !! \memberof psb_i_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine i_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -476,39 +476,39 @@ contains !> Function base_free: !! \memberof psb_i_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine i_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine i_base_free - + ! !> Function base_free_buffer: !! \memberof psb_i_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine i_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -523,17 +523,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine i_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -543,13 +543,13 @@ contains !> Function base_free_comid: !! \memberof psb_i_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine i_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -561,77 +561,77 @@ contains ! ! 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. - !! + !! ! subroutine i_base_sync(x) - implicit none + 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. - !! + !! ! subroutine i_base_set_host(x) - implicit none + 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. - !! + !! ! subroutine i_base_set_dev(x) - implicit none + 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. - !! + !! ! subroutine i_base_set_sync(x) - implicit none + 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 . - !! + !! ! function i_base_is_dev(x) result(res) - implicit none + 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 . - !! + !! ! function i_base_is_host(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x logical :: res @@ -642,10 +642,10 @@ contains !> Function base_is_sync !! \memberof psb_i_base_vect_type !! \brief Is vector on sync . - !! + !! ! function i_base_is_sync(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x logical :: res @@ -654,16 +654,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_i_base_vect_type !! \brief Number of entries - !! + !! ! function i_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -676,13 +676,13 @@ contains !> Function base_get_sizeof !! \memberof psb_i_base_vect_type !! \brief Size in bytes - !! + !! ! function i_base_sizeof(x) result(res) - implicit none + 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() @@ -692,14 +692,14 @@ contains !> Function base_get_fmt !! \memberof psb_i_base_vect_type !! \brief Format - !! + !! ! function i_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function i_base_get_fmt - + ! ! @@ -708,7 +708,7 @@ contains !! \memberof psb_i_base_vect_type !! \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(:) @@ -716,21 +716,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + 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 + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function i_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -739,18 +739,18 @@ contains !! \param val The value to set !! subroutine i_base_set_scal(x,val,first,last) - implicit none + 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_) :: info, first_, last_ 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() x%v(first_:last_) = val call x%set_host() @@ -762,14 +762,14 @@ contains !> Function base_set_vect !! \memberof psb_i_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine i_base_set_vect(x,val,first,last) - implicit none + 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_) :: info, first_, last_, nr first_ = 1 @@ -777,7 +777,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -788,8 +788,8 @@ contains end subroutine i_base_set_vect - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -804,18 +804,18 @@ contains !! \param beta subroutine i_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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 @@ -824,28 +824,28 @@ contains !! \param idx(:) indices subroutine i_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,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. + ! New comm internals impl. ! subroutine i_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -858,22 +858,22 @@ contains !> 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 - + 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 + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -883,7 +883,7 @@ contains subroutine i_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -894,7 +894,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_i_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -903,20 +903,20 @@ contains !! \param idx(:) indices subroutine i_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_i_base_vect_type @@ -925,14 +925,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine i_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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() @@ -941,12 +941,12 @@ contains subroutine i_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n 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() @@ -955,14 +955,14 @@ contains subroutine i_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: beta class(psb_i_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -987,22 +987,22 @@ module psb_i_base_multivect_mod use psb_i_base_vect_mod !> \namespace psb_base_mod \class psb_i_base_vect_type - !! The psb_i_base_vect_type + !! The psb_i_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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. !! - private + private public :: psb_i_base_multivect, psb_i_base_multivect_type type psb_i_base_multivect_type - !> Values. + !> Values. integer(psb_ipk_), allocatable :: v(:,:) - integer(psb_ipk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1016,7 +1016,7 @@ module psb_i_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => i_base_mlv_ins procedure, pass(x) :: zero => i_base_mlv_zero @@ -1027,7 +1027,7 @@ module psb_i_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => i_base_mlv_sync procedure, pass(x) :: is_host => i_base_mlv_is_host @@ -1067,7 +1067,7 @@ module psb_i_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => i_base_mlv_gthab procedure, pass(x) :: gthzv => i_base_mlv_gthzv @@ -1089,7 +1089,7 @@ module psb_i_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1108,7 +1108,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1135,7 +1135,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1150,7 +1150,7 @@ contains !> Function bld_n: !! \memberof psb_i_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine i_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1167,13 +1167,13 @@ contains !! \memberof psb_i_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \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 + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1191,7 +1191,7 @@ contains subroutine i_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -1205,21 +1205,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_i_base_multivect_type - !! \brief Insert coefficients. + !! \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 @@ -1229,7 +1229,7 @@ contains ! subroutine i_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1239,21 +1239,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -1261,7 +1261,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1278,7 +1278,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1293,7 +1293,7 @@ contains ! subroutine i_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=izero @@ -1309,7 +1309,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_i_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1318,7 +1318,7 @@ contains subroutine i_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1335,20 +1335,20 @@ contains !> Function base_mlv_free: !! \memberof psb_i_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine i_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine i_base_mlv_free @@ -1358,15 +1358,15 @@ contains ! ! 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. - !! + !! ! subroutine i_base_mlv_sync(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_sync @@ -1375,10 +1375,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_i_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine i_base_mlv_set_host(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_set_host @@ -1387,10 +1387,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_i_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine i_base_mlv_set_dev(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_set_dev @@ -1399,10 +1399,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_i_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine i_base_mlv_set_sync(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_set_sync @@ -1411,10 +1411,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_i_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function i_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x logical :: res @@ -1425,10 +1425,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_i_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function i_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x logical :: res @@ -1439,10 +1439,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_i_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function i_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x logical :: res @@ -1451,16 +1451,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_i_base_multivect_type !! \brief Number of entries - !! + !! ! function i_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1470,7 +1470,7 @@ contains end function i_base_mlv_get_nrows function i_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1483,10 +1483,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_i_base_multivect_type !! \brief Size in bytesa - !! + !! ! function i_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1499,10 +1499,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_i_base_multivect_type !! \brief Format - !! + !! ! function i_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function i_base_mlv_get_fmt @@ -1515,18 +1515,18 @@ contains !! \memberof psb_i_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function i_base_mlv_get_vect(x) result(res) - implicit none + 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 + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -1534,7 +1534,7 @@ contains end function i_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -1543,7 +1543,7 @@ contains !! \param val The value to set !! subroutine i_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val @@ -1556,16 +1556,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_i_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine i_base_mlv_set_vect(x,val) - implicit none + 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 + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -1578,15 +1578,15 @@ contains function i_base_mlv_use_buffer() result(res) - implicit none + 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 + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1598,7 +1598,7 @@ contains subroutine i_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1609,12 +1609,12 @@ contains subroutine i_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -1622,7 +1622,7 @@ contains subroutine i_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1632,7 +1632,7 @@ contains subroutine i_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1655,7 +1655,7 @@ contains !! \param beta subroutine i_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: alpha, beta, y(:) class(psb_i_base_multivect_type) :: x @@ -1671,7 +1671,7 @@ contains 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 @@ -1680,7 +1680,7 @@ contains !! \param idx(:) indices subroutine i_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: y(:) @@ -1693,7 +1693,7 @@ contains ! ! 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 @@ -1702,7 +1702,7 @@ contains !! \param idx(:) indices subroutine i_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: y(:) class(psb_i_base_multivect_type) :: x @@ -1719,7 +1719,7 @@ contains 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 @@ -1728,7 +1728,7 @@ contains !! \param idx(:) indices subroutine i_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: y(:,:) class(psb_i_base_multivect_type) :: x @@ -1745,17 +1745,17 @@ contains end subroutine i_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine i_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_i_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1767,9 +1767,9 @@ contains end subroutine i_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_i_base_multivect_type @@ -1778,10 +1778,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine i_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: beta, x(:) class(psb_i_base_multivect_type) :: y @@ -1796,7 +1796,7 @@ contains subroutine i_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: beta, x(:,:) class(psb_i_base_multivect_type) :: y @@ -1811,7 +1811,7 @@ contains subroutine i_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer( psb_ipk_) :: beta, x(:) @@ -1823,14 +1823,14 @@ contains subroutine i_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n 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 + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1839,19 +1839,18 @@ contains 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. - !! + !! ! subroutine i_base_mlv_device_wait() - implicit none - + implicit none + end subroutine i_base_mlv_device_wait end module psb_i_base_multivect_mod - diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 0661fbe0..d3aaa48e 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,22 +27,22 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_i_vect_mod ! ! This module contains the definition of the psb_i_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_i_vect_mod use psb_i_base_vect_mod type psb_i_vect_type - class(psb_i_base_vect_type), allocatable :: v + class(psb_i_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => i_vect_get_nrows procedure, pass(x) :: sizeof => i_vect_sizeof @@ -114,11 +114,11 @@ module psb_i_vect_mod contains - subroutine psb_i_set_vect_default(v) - implicit none + subroutine psb_i_set_vect_default(v) + implicit none class(psb_i_base_vect_type), intent(in) :: v - if (allocated(psb_i_base_vect_default)) then + if (allocated(psb_i_base_vect_default)) then deallocate(psb_i_base_vect_default) end if allocate(psb_i_base_vect_default, mold=v) @@ -126,7 +126,7 @@ contains end subroutine psb_i_set_vect_default function psb_i_get_vect_default(v) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: v class(psb_i_base_vect_type), pointer :: res @@ -136,10 +136,10 @@ contains function psb_i_get_base_vect_default() result(res) - implicit none + implicit none class(psb_i_base_vect_type), pointer :: res - if (.not.allocated(psb_i_base_vect_default)) then + if (.not.allocated(psb_i_base_vect_default)) then allocate(psb_i_base_vect_type :: psb_i_base_vect_default) end if @@ -149,14 +149,14 @@ contains subroutine i_vect_clone(x,y,info) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine i_vect_clone @@ -171,7 +171,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) @@ -193,7 +193,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) @@ -214,7 +214,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) @@ -277,7 +277,7 @@ contains end function size_const function i_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -285,7 +285,7 @@ contains end function i_vect_get_nrows function i_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -293,7 +293,7 @@ contains end function i_vect_sizeof function i_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -302,7 +302,7 @@ contains subroutine i_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold @@ -311,12 +311,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_i_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -326,12 +326,12 @@ contains subroutine i_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -341,7 +341,7 @@ contains subroutine i_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -351,7 +351,7 @@ contains subroutine i_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -397,12 +397,12 @@ contains subroutine i_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -411,7 +411,7 @@ contains subroutine i_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -421,7 +421,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -432,7 +432,7 @@ contains subroutine i_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -442,7 +442,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -460,12 +460,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_i_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -476,7 +476,7 @@ contains subroutine i_vect_sync(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -485,7 +485,7 @@ contains end subroutine i_vect_sync subroutine i_vect_set_sync(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -494,7 +494,7 @@ contains end subroutine i_vect_set_sync subroutine i_vect_set_host(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -503,7 +503,7 @@ contains end subroutine i_vect_set_host subroutine i_vect_set_dev(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -512,7 +512,7 @@ contains end subroutine i_vect_set_dev function i_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x @@ -523,7 +523,7 @@ contains end function i_vect_is_sync function i_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x @@ -534,11 +534,11 @@ contains end function i_vect_is_host function i_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -559,7 +559,7 @@ module psb_i_multivect_mod !private type psb_i_multivect_type - class(psb_i_base_multivect_type), allocatable :: v + class(psb_i_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => i_vect_get_nrows procedure, pass(x) :: get_ncols => i_vect_get_ncols @@ -615,11 +615,11 @@ module psb_i_multivect_mod contains - subroutine psb_i_set_multivect_default(v) - implicit none + subroutine psb_i_set_multivect_default(v) + implicit none class(psb_i_base_multivect_type), intent(in) :: v - if (allocated(psb_i_base_multivect_default)) then + if (allocated(psb_i_base_multivect_default)) then deallocate(psb_i_base_multivect_default) end if allocate(psb_i_base_multivect_default, mold=v) @@ -627,7 +627,7 @@ contains end subroutine psb_i_set_multivect_default function psb_i_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: v class(psb_i_base_multivect_type), pointer :: res @@ -637,10 +637,10 @@ contains function psb_i_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_i_base_multivect_type), pointer :: res - if (.not.allocated(psb_i_base_multivect_default)) then + if (.not.allocated(psb_i_base_multivect_default)) then allocate(psb_i_base_multivect_type :: psb_i_base_multivect_default) end if @@ -650,14 +650,14 @@ contains subroutine i_vect_clone(x,y,info) - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x class(psb_i_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine i_vect_clone @@ -670,7 +670,7 @@ contains class(psb_i_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) @@ -688,7 +688,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) @@ -748,7 +748,7 @@ contains end function size_const function i_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -756,7 +756,7 @@ contains end function i_vect_get_nrows function i_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -764,7 +764,7 @@ contains end function i_vect_get_ncols function i_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -772,7 +772,7 @@ contains end function i_vect_sizeof function i_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -781,18 +781,18 @@ contains subroutine i_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_multivect_type), intent(out) :: x class(psb_i_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_i_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -802,12 +802,12 @@ contains subroutine i_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -817,7 +817,7 @@ contains subroutine i_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -827,7 +827,7 @@ contains subroutine i_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -838,7 +838,7 @@ contains end subroutine i_vect_asb subroutine i_vect_sync(x) - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -906,12 +906,12 @@ contains subroutine i_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -920,7 +920,7 @@ contains subroutine i_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -930,7 +930,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -946,12 +946,12 @@ contains class(psb_i_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_i_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) diff --git a/base/modules/serial/psb_l_base_vect_mod.f90 b/base/modules/serial/psb_l_base_vect_mod.f90 index ab7b49f1..37bdf485 100644 --- a/base/modules/serial/psb_l_base_vect_mod.f90 +++ b/base/modules/serial/psb_l_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,14 +27,14 @@ ! 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 +! 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 @@ -43,16 +43,16 @@ ! ! module psb_l_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod !> \namespace psb_base_mod \class psb_l_base_vect_type - !! The psb_l_base_vect_type + !! The psb_l_base_vect_type !! defines a middle level integer(psb_lpk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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 @@ -60,9 +60,9 @@ module psb_l_base_vect_mod !! sparse matrix types. !! type psb_l_base_vect_type - !> Values. + !> Values. integer(psb_lpk_), allocatable :: v(:) - integer(psb_lpk_), allocatable :: combuf(:) + integer(psb_lpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -77,7 +77,7 @@ module psb_l_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => l_base_ins_a procedure, pass(x) :: ins_v => l_base_ins_v @@ -92,7 +92,7 @@ module psb_l_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => l_base_sync procedure, pass(x) :: is_host => l_base_is_host @@ -129,7 +129,7 @@ module psb_l_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => l_base_gthab procedure, pass(x) :: gthzv => l_base_gthzv @@ -152,11 +152,11 @@ module psb_l_base_vect_mod end interface psb_l_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -169,11 +169,11 @@ contains 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. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -183,7 +183,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -195,20 +195,20 @@ contains !! subroutine l_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: this(:) class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine l_base_bld_x - + ! ! Create with size, but no initialization ! @@ -216,11 +216,11 @@ contains !> Function bld_mn: !! \memberof psb_l_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine l_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -229,15 +229,15 @@ contains call x%asb(n,info) 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. + !! \param n size to be allocated. !! subroutine l_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -246,24 +246,24 @@ contains call x%asb(n,info) 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 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 + 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) - + end subroutine l_base_all !> Function base_mold: @@ -275,11 +275,11 @@ contains subroutine l_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -289,21 +289,21 @@ contains ! !> Function base_ins: !! \memberof psb_l_base_vect_type - !! \brief Insert coefficients. + !! \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 @@ -313,7 +313,7 @@ contains ! subroutine l_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -323,21 +323,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -345,7 +345,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -363,7 +363,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -372,7 +372,7 @@ contains subroutine l_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -382,14 +382,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + 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,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -405,14 +405,14 @@ contains ! subroutine l_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=lzero call x%set_host() end subroutine l_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -421,20 +421,20 @@ contains !> Function base_asb: !! \memberof psb_l_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine l_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -451,20 +451,20 @@ contains !> Function base_asb: !! \memberof psb_l_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine l_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -477,39 +477,39 @@ contains !> Function base_free: !! \memberof psb_l_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine l_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine l_base_free - + ! !> Function base_free_buffer: !! \memberof psb_l_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine l_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -524,17 +524,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine l_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -544,13 +544,13 @@ contains !> Function base_free_comid: !! \memberof psb_l_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine l_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -562,77 +562,77 @@ contains ! ! 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. - !! + !! ! subroutine l_base_sync(x) - implicit none + 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. - !! + !! ! subroutine l_base_set_host(x) - implicit none + 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. - !! + !! ! subroutine l_base_set_dev(x) - implicit none + 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. - !! + !! ! subroutine l_base_set_sync(x) - implicit none + 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 . - !! + !! ! function l_base_is_dev(x) result(res) - implicit none + 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 . - !! + !! ! function l_base_is_host(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x logical :: res @@ -643,10 +643,10 @@ contains !> Function base_is_sync !! \memberof psb_l_base_vect_type !! \brief Is vector on sync . - !! + !! ! function l_base_is_sync(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x logical :: res @@ -655,16 +655,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_l_base_vect_type !! \brief Number of entries - !! + !! ! function l_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -677,13 +677,13 @@ contains !> Function base_get_sizeof !! \memberof psb_l_base_vect_type !! \brief Size in bytes - !! + !! ! function l_base_sizeof(x) result(res) - implicit none + 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() @@ -693,14 +693,14 @@ contains !> Function base_get_fmt !! \memberof psb_l_base_vect_type !! \brief Format - !! + !! ! function l_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function l_base_get_fmt - + ! ! @@ -709,7 +709,7 @@ contains !! \memberof psb_l_base_vect_type !! \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(:) @@ -717,21 +717,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + 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 + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function l_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -740,18 +740,18 @@ contains !! \param val The value to set !! subroutine l_base_set_scal(x,val,first,last) - implicit none + 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_) :: info, first_, last_ 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() x%v(first_:last_) = val call x%set_host() @@ -763,14 +763,14 @@ contains !> Function base_set_vect !! \memberof psb_l_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine l_base_set_vect(x,val,first,last) - implicit none + 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_) :: info, first_, last_, nr first_ = 1 @@ -778,7 +778,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -789,8 +789,8 @@ contains end subroutine l_base_set_vect - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -805,18 +805,18 @@ contains !! \param beta subroutine l_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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 @@ -825,28 +825,28 @@ contains !! \param idx(:) indices subroutine l_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,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. + ! New comm internals impl. ! subroutine l_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_l_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -859,22 +859,22 @@ contains !> 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 - + 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 + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -884,7 +884,7 @@ contains subroutine l_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -895,7 +895,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_l_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -904,20 +904,20 @@ contains !! \param idx(:) indices subroutine l_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_l_base_vect_type @@ -926,14 +926,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine l_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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() @@ -942,12 +942,12 @@ contains subroutine l_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n 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() @@ -956,14 +956,14 @@ contains subroutine l_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer(psb_lpk_) :: beta class(psb_l_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -988,22 +988,22 @@ module psb_l_base_multivect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_l_base_vect_type - !! The psb_l_base_vect_type + !! The psb_l_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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. !! - private + private public :: psb_l_base_multivect, psb_l_base_multivect_type type psb_l_base_multivect_type - !> Values. + !> Values. integer(psb_lpk_), allocatable :: v(:,:) - integer(psb_lpk_), allocatable :: combuf(:) + integer(psb_lpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1017,7 +1017,7 @@ module psb_l_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => l_base_mlv_ins procedure, pass(x) :: zero => l_base_mlv_zero @@ -1028,7 +1028,7 @@ module psb_l_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => l_base_mlv_sync procedure, pass(x) :: is_host => l_base_mlv_is_host @@ -1068,7 +1068,7 @@ module psb_l_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => l_base_mlv_gthab procedure, pass(x) :: gthzv => l_base_mlv_gthzv @@ -1090,7 +1090,7 @@ module psb_l_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1109,7 +1109,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1136,7 +1136,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1151,7 +1151,7 @@ contains !> Function bld_n: !! \memberof psb_l_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine l_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1168,13 +1168,13 @@ contains !! \memberof psb_l_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \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 + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1192,7 +1192,7 @@ contains subroutine l_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -1206,21 +1206,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_l_base_multivect_type - !! \brief Insert coefficients. + !! \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 @@ -1230,7 +1230,7 @@ contains ! subroutine l_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1240,21 +1240,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -1262,7 +1262,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1279,7 +1279,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1294,7 +1294,7 @@ contains ! subroutine l_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=lzero @@ -1310,7 +1310,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_l_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1319,7 +1319,7 @@ contains subroutine l_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1336,20 +1336,20 @@ contains !> Function base_mlv_free: !! \memberof psb_l_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine l_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine l_base_mlv_free @@ -1359,15 +1359,15 @@ contains ! ! 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. - !! + !! ! subroutine l_base_mlv_sync(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_sync @@ -1376,10 +1376,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_l_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine l_base_mlv_set_host(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_set_host @@ -1388,10 +1388,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_l_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine l_base_mlv_set_dev(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_set_dev @@ -1400,10 +1400,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_l_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine l_base_mlv_set_sync(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_set_sync @@ -1412,10 +1412,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_l_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function l_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x logical :: res @@ -1426,10 +1426,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_l_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function l_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x logical :: res @@ -1440,10 +1440,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_l_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function l_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x logical :: res @@ -1452,16 +1452,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_l_base_multivect_type !! \brief Number of entries - !! + !! ! function l_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1471,7 +1471,7 @@ contains end function l_base_mlv_get_nrows function l_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1484,10 +1484,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_l_base_multivect_type !! \brief Size in bytesa - !! + !! ! function l_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1500,10 +1500,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_l_base_multivect_type !! \brief Format - !! + !! ! function l_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function l_base_mlv_get_fmt @@ -1516,18 +1516,18 @@ contains !! \memberof psb_l_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function l_base_mlv_get_vect(x) result(res) - implicit none + 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 + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -1535,7 +1535,7 @@ contains end function l_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -1544,7 +1544,7 @@ contains !! \param val The value to set !! subroutine l_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_lpk_), intent(in) :: val @@ -1557,16 +1557,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_l_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine l_base_mlv_set_vect(x,val) - implicit none + 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 + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -1579,15 +1579,15 @@ contains function l_base_mlv_use_buffer() result(res) - implicit none + 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 + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1599,7 +1599,7 @@ contains subroutine l_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1610,12 +1610,12 @@ contains subroutine l_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -1623,7 +1623,7 @@ contains subroutine l_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1633,7 +1633,7 @@ contains subroutine l_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1656,7 +1656,7 @@ contains !! \param beta subroutine l_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: alpha, beta, y(:) class(psb_l_base_multivect_type) :: x @@ -1672,7 +1672,7 @@ contains 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 @@ -1681,7 +1681,7 @@ contains !! \param idx(:) indices subroutine l_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx integer(psb_lpk_) :: y(:) @@ -1694,7 +1694,7 @@ contains ! ! 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 @@ -1703,7 +1703,7 @@ contains !! \param idx(:) indices subroutine l_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: y(:) class(psb_l_base_multivect_type) :: x @@ -1720,7 +1720,7 @@ contains 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 @@ -1729,7 +1729,7 @@ contains !! \param idx(:) indices subroutine l_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: y(:,:) class(psb_l_base_multivect_type) :: x @@ -1746,17 +1746,17 @@ contains end subroutine l_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine l_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_l_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1768,9 +1768,9 @@ contains end subroutine l_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_l_base_multivect_type @@ -1779,10 +1779,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine l_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: beta, x(:) class(psb_l_base_multivect_type) :: y @@ -1797,7 +1797,7 @@ contains subroutine l_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: beta, x(:,:) class(psb_l_base_multivect_type) :: y @@ -1812,7 +1812,7 @@ contains subroutine l_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer( psb_lpk_) :: beta, x(:) @@ -1824,14 +1824,14 @@ contains subroutine l_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n 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 + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1840,19 +1840,18 @@ contains 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. - !! + !! ! subroutine l_base_mlv_device_wait() - implicit none - + implicit none + end subroutine l_base_mlv_device_wait end module psb_l_base_multivect_mod - diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index 5d0369d6..ece6ee66 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_l_vect_mod ! ! This module contains the definition of the psb_l_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_l_vect_mod @@ -43,7 +43,7 @@ module psb_l_vect_mod use psb_i_vect_mod type psb_l_vect_type - class(psb_l_base_vect_type), allocatable :: v + class(psb_l_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => l_vect_get_nrows procedure, pass(x) :: sizeof => l_vect_sizeof @@ -115,11 +115,11 @@ module psb_l_vect_mod contains - subroutine psb_l_set_vect_default(v) - implicit none + subroutine psb_l_set_vect_default(v) + implicit none class(psb_l_base_vect_type), intent(in) :: v - if (allocated(psb_l_base_vect_default)) then + if (allocated(psb_l_base_vect_default)) then deallocate(psb_l_base_vect_default) end if allocate(psb_l_base_vect_default, mold=v) @@ -127,7 +127,7 @@ contains end subroutine psb_l_set_vect_default function psb_l_get_vect_default(v) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: v class(psb_l_base_vect_type), pointer :: res @@ -137,10 +137,10 @@ contains function psb_l_get_base_vect_default() result(res) - implicit none + implicit none class(psb_l_base_vect_type), pointer :: res - if (.not.allocated(psb_l_base_vect_default)) then + if (.not.allocated(psb_l_base_vect_default)) then allocate(psb_l_base_vect_type :: psb_l_base_vect_default) end if @@ -150,14 +150,14 @@ contains subroutine l_vect_clone(x,y,info) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine l_vect_clone @@ -172,7 +172,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) @@ -194,7 +194,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) @@ -215,7 +215,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) @@ -278,7 +278,7 @@ contains end function size_const function l_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -286,7 +286,7 @@ contains end function l_vect_get_nrows function l_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -294,7 +294,7 @@ contains end function l_vect_sizeof function l_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -303,7 +303,7 @@ contains subroutine l_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(in), optional :: mold @@ -312,12 +312,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_l_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -327,12 +327,12 @@ contains subroutine l_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -342,7 +342,7 @@ contains subroutine l_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -352,7 +352,7 @@ contains subroutine l_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -398,12 +398,12 @@ contains subroutine l_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -412,7 +412,7 @@ contains subroutine l_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -422,7 +422,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -433,7 +433,7 @@ contains subroutine l_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -443,7 +443,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -461,12 +461,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_l_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -477,7 +477,7 @@ contains subroutine l_vect_sync(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -486,7 +486,7 @@ contains end subroutine l_vect_sync subroutine l_vect_set_sync(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -495,7 +495,7 @@ contains end subroutine l_vect_set_sync subroutine l_vect_set_host(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -504,7 +504,7 @@ contains end subroutine l_vect_set_host subroutine l_vect_set_dev(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -513,7 +513,7 @@ contains end subroutine l_vect_set_dev function l_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_l_vect_type), intent(inout) :: x @@ -524,7 +524,7 @@ contains end function l_vect_is_sync function l_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_l_vect_type), intent(inout) :: x @@ -535,11 +535,11 @@ contains end function l_vect_is_host function l_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_l_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -560,7 +560,7 @@ module psb_l_multivect_mod !private type psb_l_multivect_type - class(psb_l_base_multivect_type), allocatable :: v + class(psb_l_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => l_vect_get_nrows procedure, pass(x) :: get_ncols => l_vect_get_ncols @@ -616,11 +616,11 @@ module psb_l_multivect_mod contains - subroutine psb_l_set_multivect_default(v) - implicit none + subroutine psb_l_set_multivect_default(v) + implicit none class(psb_l_base_multivect_type), intent(in) :: v - if (allocated(psb_l_base_multivect_default)) then + if (allocated(psb_l_base_multivect_default)) then deallocate(psb_l_base_multivect_default) end if allocate(psb_l_base_multivect_default, mold=v) @@ -628,7 +628,7 @@ contains end subroutine psb_l_set_multivect_default function psb_l_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: v class(psb_l_base_multivect_type), pointer :: res @@ -638,10 +638,10 @@ contains function psb_l_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_l_base_multivect_type), pointer :: res - if (.not.allocated(psb_l_base_multivect_default)) then + if (.not.allocated(psb_l_base_multivect_default)) then allocate(psb_l_base_multivect_type :: psb_l_base_multivect_default) end if @@ -651,14 +651,14 @@ contains subroutine l_vect_clone(x,y,info) - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x class(psb_l_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine l_vect_clone @@ -671,7 +671,7 @@ contains class(psb_l_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) @@ -689,7 +689,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) @@ -749,7 +749,7 @@ contains end function size_const function l_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -757,7 +757,7 @@ contains end function l_vect_get_nrows function l_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -765,7 +765,7 @@ contains end function l_vect_get_ncols function l_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -773,7 +773,7 @@ contains end function l_vect_sizeof function l_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -782,18 +782,18 @@ contains subroutine l_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_multivect_type), intent(out) :: x class(psb_l_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_l_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -803,12 +803,12 @@ contains subroutine l_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -818,7 +818,7 @@ contains subroutine l_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -828,7 +828,7 @@ contains subroutine l_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -839,7 +839,7 @@ contains end subroutine l_vect_asb subroutine l_vect_sync(x) - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -907,12 +907,12 @@ contains subroutine l_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -921,7 +921,7 @@ contains subroutine l_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -931,7 +931,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -947,12 +947,12 @@ contains class(psb_l_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_l_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 2d716290..a47d6377 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,14 +27,14 @@ ! 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 +! 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 @@ -43,7 +43,7 @@ ! ! module psb_s_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_s_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_s_base_vect_type - !! The psb_s_base_vect_type + !! The psb_s_base_vect_type !! defines a middle level real(psb_spk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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 @@ -61,9 +61,9 @@ module psb_s_base_vect_mod !! sparse matrix types. !! type psb_s_base_vect_type - !> Values. + !> Values. real(psb_spk_), allocatable :: v(:) - real(psb_spk_), allocatable :: combuf(:) + real(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_s_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => s_base_ins_a procedure, pass(x) :: ins_v => s_base_ins_v @@ -93,7 +93,7 @@ module psb_s_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => s_base_sync procedure, pass(x) :: is_host => s_base_is_host @@ -130,7 +130,7 @@ module psb_s_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => s_base_gthab procedure, pass(x) :: gthzv => s_base_gthzv @@ -164,6 +164,12 @@ module psb_s_base_vect_mod procedure, pass(z) :: mlt_av => s_base_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => s_base_div_v + procedure, pass(z) :: div_a2 => s_base_div_a2 + generic, public :: div => div_v, div_a2 + ! ! Scaling and norms ! procedure, pass(x) :: scal => s_base_scal @@ -183,11 +189,11 @@ module psb_s_base_vect_mod end interface psb_s_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +206,11 @@ contains 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. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +220,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +232,20 @@ contains !! subroutine s_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none real(psb_spk_), intent(in) :: this(:) class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine s_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +253,11 @@ contains !> Function bld_mn: !! \memberof psb_s_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine s_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +266,15 @@ contains call x%asb(n,info) 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. + !! \param n size to be allocated. !! subroutine s_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +283,24 @@ contains call x%asb(n,info) 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 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 + 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) - + end subroutine s_base_all !> Function base_mold: @@ -306,11 +312,11 @@ contains subroutine s_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -320,21 +326,21 @@ contains ! !> Function base_ins: !! \memberof psb_s_base_vect_type - !! \brief Insert coefficients. + !! \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 @@ -344,7 +350,7 @@ contains ! subroutine s_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +360,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -376,7 +382,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +400,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +409,7 @@ contains subroutine s_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +419,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + 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,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +442,14 @@ contains ! subroutine s_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=szero call x%set_host() end subroutine s_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +458,20 @@ contains !> Function base_asb: !! \memberof psb_s_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine s_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +488,20 @@ contains !> Function base_asb: !! \memberof psb_s_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine s_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +514,39 @@ contains !> Function base_free: !! \memberof psb_s_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine s_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine s_base_free - + ! !> Function base_free_buffer: !! \memberof psb_s_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine s_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +561,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine s_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +581,13 @@ contains !> Function base_free_comid: !! \memberof psb_s_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine s_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +599,77 @@ contains ! ! 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. - !! + !! ! subroutine s_base_sync(x) - implicit none + 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. - !! + !! ! subroutine s_base_set_host(x) - implicit none + 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. - !! + !! ! subroutine s_base_set_dev(x) - implicit none + 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. - !! + !! ! subroutine s_base_set_sync(x) - implicit none + 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 . - !! + !! ! function s_base_is_dev(x) result(res) - implicit none + 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 . - !! + !! ! function s_base_is_host(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +680,10 @@ contains !> Function base_is_sync !! \memberof psb_s_base_vect_type !! \brief Is vector on sync . - !! + !! ! function s_base_is_sync(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +692,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_s_base_vect_type !! \brief Number of entries - !! + !! ! function s_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +714,13 @@ contains !> Function base_get_sizeof !! \memberof psb_s_base_vect_type !! \brief Size in bytes - !! + !! ! function s_base_sizeof(x) result(res) - implicit none + 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() @@ -724,14 +730,14 @@ contains !> Function base_get_fmt !! \memberof psb_s_base_vect_type !! \brief Format - !! + !! ! function s_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function s_base_get_fmt - + ! ! @@ -740,7 +746,7 @@ contains !! \memberof psb_s_base_vect_type !! \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(:) @@ -748,21 +754,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + 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 + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function s_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +777,18 @@ contains !! \param val The value to set !! subroutine s_base_set_scal(x,val,first,last) - implicit none + 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_) :: info, first_, last_ 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() x%v(first_:last_) = val call x%set_host() @@ -794,14 +800,14 @@ contains !> Function base_set_vect !! \memberof psb_s_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine s_base_set_vect(x,val,first,last) - implicit none + 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_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +815,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +835,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine s_base_absval1(x) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +847,21 @@ contains end subroutine s_base_absval1 subroutine s_base_absval2(x,y) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x + 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 + 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 - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_s_base_vect_type @@ -864,12 +870,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function s_base_dot_v(n,x,y) result(res) - implicit none + 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. @@ -898,19 +904,19 @@ contains !! \param y(:) The array to be multiplied by !! function s_base_dot_a(n,x,y) result(res) - implicit none + 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. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +931,13 @@ contains !! subroutine s_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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) @@ -939,7 +945,7 @@ contains end subroutine s_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +959,20 @@ contains !! subroutine s_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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 - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +990,10 @@ contains !! subroutine s_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1011,7 @@ contains !! subroutine s_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:) class(psb_s_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1020,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1041,7 @@ contains !! subroutine s_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:) real(psb_spk_), intent(in) :: x(:) @@ -1043,58 +1049,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + 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 + if (alpha == szero) then + if (beta == sone) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == sone) then - if (beta == szero) then - do i=1, n + if (alpha == sone) then + if (beta == szero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == sone) then - do i=1, n + else if (beta == sone) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + 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 - do i=1, n + else if (alpha == -sone) then + if (beta == szero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == sone) then - do i=1, n + else if (beta == sone) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == szero) then - do i=1, n + if (beta == szero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == sone) then - do i=1, n + else if (beta == sone) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1124,12 @@ contains subroutine s_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1139,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1154,12 @@ contains subroutine s_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1170,12 @@ contains subroutine s_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1183,57 @@ contains 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 + !! + 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 ! - ! Simple scaling + !> Function base_div_a2 + !! \memberof psb_s_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y + !! \param x(:) The array to be multiplied 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)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine s_base_div_a2 + + + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_s_base_vect_type @@ -1189,17 +1242,17 @@ contains !! subroutine s_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x real(psb_spk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine s_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,28 +1261,28 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function s_base_nrm2(n,x) result(res) - implicit none + 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 function s_base_amax(n,x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) @@ -1241,17 +1294,17 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function s_base_asum(n,x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function s_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1319,18 @@ contains !! \param beta subroutine s_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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 @@ -1286,28 +1339,28 @@ contains !! \param idx(:) indices subroutine s_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,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. + ! New comm internals impl. ! subroutine s_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_s_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1373,22 @@ contains !> 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 - + 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 + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1398,7 @@ contains subroutine s_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1409,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_s_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1418,20 @@ contains !! \param idx(:) indices subroutine s_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_s_base_vect_type @@ -1387,14 +1440,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine s_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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() @@ -1403,12 +1456,12 @@ contains subroutine s_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n 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() @@ -1417,14 +1470,14 @@ contains subroutine s_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real(psb_spk_) :: beta class(psb_s_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1449,22 +1502,22 @@ module psb_s_base_multivect_mod use psb_s_base_vect_mod !> \namespace psb_base_mod \class psb_s_base_vect_type - !! The psb_s_base_vect_type + !! The psb_s_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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. !! - private + private public :: psb_s_base_multivect, psb_s_base_multivect_type type psb_s_base_multivect_type - !> Values. + !> Values. real(psb_spk_), allocatable :: v(:,:) - real(psb_spk_), allocatable :: combuf(:) + real(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +1531,7 @@ module psb_s_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => s_base_mlv_ins procedure, pass(x) :: zero => s_base_mlv_zero @@ -1489,7 +1542,7 @@ module psb_s_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => s_base_mlv_sync procedure, pass(x) :: is_host => s_base_mlv_is_host @@ -1562,7 +1615,7 @@ module psb_s_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => s_base_mlv_gthab procedure, pass(x) :: gthzv => s_base_mlv_gthzv @@ -1584,7 +1637,7 @@ module psb_s_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +1656,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +1683,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +1698,7 @@ contains !> Function bld_n: !! \memberof psb_s_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine s_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +1715,13 @@ contains !! \memberof psb_s_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \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 + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +1739,7 @@ contains subroutine s_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -1700,21 +1753,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_s_base_multivect_type - !! \brief Insert coefficients. + !! \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 @@ -1724,7 +1777,7 @@ contains ! subroutine s_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +1787,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -1756,7 +1809,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +1826,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +1841,7 @@ contains ! subroutine s_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=szero @@ -1804,7 +1857,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_s_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +1866,7 @@ contains subroutine s_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +1883,20 @@ contains !> Function base_mlv_free: !! \memberof psb_s_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine s_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine s_base_mlv_free @@ -1853,15 +1906,15 @@ contains ! ! 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. - !! + !! ! subroutine s_base_mlv_sync(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_sync @@ -1870,10 +1923,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_s_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine s_base_mlv_set_host(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_set_host @@ -1882,10 +1935,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_s_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine s_base_mlv_set_dev(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_set_dev @@ -1894,10 +1947,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_s_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine s_base_mlv_set_sync(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_set_sync @@ -1906,10 +1959,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_s_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function s_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +1973,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_s_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function s_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +1987,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_s_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function s_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +1999,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_s_base_multivect_type !! \brief Number of entries - !! + !! ! function s_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2018,7 @@ contains end function s_base_mlv_get_nrows function s_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2031,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_s_base_multivect_type !! \brief Size in bytesa - !! + !! ! function s_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2047,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_s_base_multivect_type !! \brief Format - !! + !! ! function s_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function s_base_mlv_get_fmt @@ -2010,18 +2063,18 @@ contains !! \memberof psb_s_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function s_base_mlv_get_vect(x) result(res) - implicit none + 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 + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2082,7 @@ contains end function s_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2091,7 @@ contains !! \param val The value to set !! subroutine s_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val @@ -2051,16 +2104,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_s_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine s_base_mlv_set_vect(x,val) - implicit none + 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 + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2125,8 @@ contains end subroutine s_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_s_base_multivect_type @@ -2082,7 +2135,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function s_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2094,7 +2147,7 @@ contains ! ! 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). + ! 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 ! @@ -2123,7 +2176,7 @@ contains !! \param y(:) The array to be multiplied by !! function s_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2194,7 @@ contains end function s_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2209,7 @@ contains !! subroutine s_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + 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 @@ -2180,7 +2233,7 @@ contains end subroutine s_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2247,7 @@ contains !! subroutine s_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent(in) :: x(:,:) class(psb_s_base_multivect_type), intent(inout) :: y @@ -2230,10 +2283,10 @@ contains !! subroutine s_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2296,10 @@ contains subroutine s_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2316,7 @@ contains !! subroutine s_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:) class(psb_s_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2324,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2339,7 @@ contains !! subroutine s_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:,:) class(psb_s_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2366,7 @@ contains !! subroutine s_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:,:) real(psb_spk_), intent(in) :: x(:,:) @@ -2321,38 +2374,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 @@ -2373,12 +2426,12 @@ contains 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 + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +2442,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +2457,39 @@ contains !!$ !!$ subroutine s_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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 + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_s_base_multivect_type @@ -2445,7 +2498,7 @@ contains !! subroutine s_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent (in) :: alpha @@ -2462,7 +2515,7 @@ contains !! \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 + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2484,7 +2537,7 @@ contains !! \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 + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2505,7 +2558,7 @@ contains !! \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 + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2528,7 +2581,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine s_base_mlv_absval1(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +2593,13 @@ contains end subroutine s_base_mlv_absval1 subroutine s_base_mlv_absval2(x,y) - implicit none + 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 + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) call y%absval() end if @@ -2555,15 +2608,15 @@ contains function s_base_mlv_use_buffer() result(res) - implicit none + 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 + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +2628,7 @@ contains subroutine s_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +2639,12 @@ contains subroutine s_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +2652,7 @@ contains subroutine s_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +2662,7 @@ contains subroutine s_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +2685,7 @@ contains !! \param beta subroutine s_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: alpha, beta, y(:) class(psb_s_base_multivect_type) :: x @@ -2648,7 +2701,7 @@ contains 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 @@ -2657,7 +2710,7 @@ contains !! \param idx(:) indices subroutine s_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx real(psb_spk_) :: y(:) @@ -2670,7 +2723,7 @@ contains ! ! 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 @@ -2679,7 +2732,7 @@ contains !! \param idx(:) indices subroutine s_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: y(:) class(psb_s_base_multivect_type) :: x @@ -2696,7 +2749,7 @@ contains 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 @@ -2705,7 +2758,7 @@ contains !! \param idx(:) indices subroutine s_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: y(:,:) class(psb_s_base_multivect_type) :: x @@ -2722,17 +2775,17 @@ contains end subroutine s_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine s_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_s_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +2797,9 @@ contains end subroutine s_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_s_base_multivect_type @@ -2755,10 +2808,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine s_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:) class(psb_s_base_multivect_type) :: y @@ -2773,7 +2826,7 @@ contains subroutine s_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:,:) class(psb_s_base_multivect_type) :: y @@ -2788,7 +2841,7 @@ contains subroutine s_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real( psb_spk_) :: beta, x(:) @@ -2800,14 +2853,14 @@ contains subroutine s_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n 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 + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +2869,18 @@ contains 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. - !! + !! ! subroutine s_base_mlv_device_wait() - implicit none - + implicit none + end subroutine s_base_mlv_device_wait 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 0907f06e..d835bc5a 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_s_vect_mod ! ! This module contains the definition of the psb_s_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_s_vect_mod @@ -43,7 +43,7 @@ module psb_s_vect_mod use psb_i_vect_mod type psb_s_vect_type - class(psb_s_base_vect_type), allocatable :: v + class(psb_s_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => s_vect_get_nrows procedure, pass(x) :: sizeof => s_vect_sizeof @@ -94,13 +94,16 @@ module psb_s_vect_mod procedure, pass(z) :: mlt_av => s_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => s_vect_div_v + procedure, pass(z) :: div_a2 => s_vect_div_a2 + generic, public :: div => div_v, div_a2 procedure, pass(x) :: scal => s_vect_scal procedure, pass(x) :: absval1 => s_vect_absval1 procedure, pass(x) :: absval2 => s_vect_absval2 generic, public :: absval => absval1, absval2 procedure, pass(x) :: nrm2 => s_vect_nrm2 procedure, pass(x) :: amax => s_vect_amax - procedure, pass(x) :: asum => s_vect_asum + procedure, pass(x) :: asum => s_vect_asum end type psb_s_vect_type public :: psb_s_vect @@ -122,7 +125,7 @@ module psb_s_vect_mod private :: s_vect_dot_v, s_vect_dot_a, s_vect_axpby_v, s_vect_axpby_a, & & s_vect_mlt_v, s_vect_mlt_a, s_vect_mlt_a_2, s_vect_mlt_v_2, & & s_vect_mlt_va, s_vect_mlt_av, s_vect_scal, s_vect_absval1, & - & s_vect_absval2, s_vect_nrm2, s_vect_amax, s_vect_asum + & s_vect_absval2, s_vect_nrm2, s_vect_amax, s_vect_asum @@ -141,11 +144,11 @@ module psb_s_vect_mod contains - subroutine psb_s_set_vect_default(v) - implicit none + subroutine psb_s_set_vect_default(v) + implicit none class(psb_s_base_vect_type), intent(in) :: v - if (allocated(psb_s_base_vect_default)) then + if (allocated(psb_s_base_vect_default)) then deallocate(psb_s_base_vect_default) end if allocate(psb_s_base_vect_default, mold=v) @@ -153,7 +156,7 @@ contains end subroutine psb_s_set_vect_default function psb_s_get_vect_default(v) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: v class(psb_s_base_vect_type), pointer :: res @@ -163,10 +166,10 @@ contains function psb_s_get_base_vect_default() result(res) - implicit none + implicit none class(psb_s_base_vect_type), pointer :: res - if (.not.allocated(psb_s_base_vect_default)) then + if (.not.allocated(psb_s_base_vect_default)) then allocate(psb_s_base_vect_type :: psb_s_base_vect_default) end if @@ -176,14 +179,14 @@ contains subroutine s_vect_clone(x,y,info) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine s_vect_clone @@ -198,7 +201,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) @@ -220,7 +223,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) @@ -241,7 +244,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) @@ -304,7 +307,7 @@ contains end function size_const function s_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -312,7 +315,7 @@ contains end function s_vect_get_nrows function s_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -320,7 +323,7 @@ contains end function s_vect_sizeof function s_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -329,7 +332,7 @@ contains subroutine s_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold @@ -338,12 +341,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_s_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -353,12 +356,12 @@ contains subroutine s_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -368,7 +371,7 @@ contains subroutine s_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -378,7 +381,7 @@ contains subroutine s_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -424,12 +427,12 @@ contains subroutine s_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -438,7 +441,7 @@ contains subroutine s_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -448,7 +451,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -459,7 +462,7 @@ contains subroutine s_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -469,7 +472,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -487,12 +490,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_s_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -503,7 +506,7 @@ contains subroutine s_vect_sync(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -512,7 +515,7 @@ contains end subroutine s_vect_sync subroutine s_vect_set_sync(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -521,7 +524,7 @@ contains end subroutine s_vect_set_sync subroutine s_vect_set_host(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -530,7 +533,7 @@ contains end subroutine s_vect_set_host subroutine s_vect_set_dev(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -539,7 +542,7 @@ contains end subroutine s_vect_set_dev function s_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x @@ -550,7 +553,7 @@ contains end function s_vect_is_sync function s_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x @@ -561,11 +564,11 @@ contains end function s_vect_is_host function s_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -573,7 +576,7 @@ contains function s_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res @@ -585,7 +588,7 @@ contains end function s_vect_dot_v function s_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x real(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -599,14 +602,14 @@ contains subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -616,7 +619,7 @@ contains subroutine s_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent(in) :: x(:) class(psb_s_vect_type), intent(inout) :: y @@ -631,10 +634,10 @@ contains subroutine s_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -645,7 +648,7 @@ contains subroutine s_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:) class(psb_s_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -661,7 +664,7 @@ contains subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:) real(psb_spk_), intent(in) :: x(:) @@ -669,7 +672,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -677,12 +680,12 @@ contains subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -696,12 +699,12 @@ contains subroutine s_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: x(:) class(psb_s_vect_type), intent(inout) :: y class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -712,12 +715,12 @@ contains subroutine s_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:) class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -727,9 +730,38 @@ contains end subroutine s_vect_mlt_va + subroutine s_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine s_vect_div_v + + subroutine s_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine s_vect_div_a2 + subroutine s_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x real(psb_spk_), intent (in) :: alpha @@ -749,19 +781,19 @@ contains class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine s_vect_absval2 function s_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = szero @@ -770,12 +802,12 @@ contains end function s_vect_nrm2 function s_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = szero @@ -784,12 +816,12 @@ contains end function s_vect_amax function s_vect_asum(n,x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%asum(n) else res = szero @@ -812,7 +844,7 @@ module psb_s_multivect_mod !private type psb_s_multivect_type - class(psb_s_base_multivect_type), allocatable :: v + class(psb_s_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => s_vect_get_nrows procedure, pass(x) :: get_ncols => s_vect_get_ncols @@ -886,11 +918,11 @@ module psb_s_multivect_mod contains - subroutine psb_s_set_multivect_default(v) - implicit none + subroutine psb_s_set_multivect_default(v) + implicit none class(psb_s_base_multivect_type), intent(in) :: v - if (allocated(psb_s_base_multivect_default)) then + if (allocated(psb_s_base_multivect_default)) then deallocate(psb_s_base_multivect_default) end if allocate(psb_s_base_multivect_default, mold=v) @@ -898,7 +930,7 @@ contains end subroutine psb_s_set_multivect_default function psb_s_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: v class(psb_s_base_multivect_type), pointer :: res @@ -908,10 +940,10 @@ contains function psb_s_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_s_base_multivect_type), pointer :: res - if (.not.allocated(psb_s_base_multivect_default)) then + if (.not.allocated(psb_s_base_multivect_default)) then allocate(psb_s_base_multivect_type :: psb_s_base_multivect_default) end if @@ -921,14 +953,14 @@ contains subroutine s_vect_clone(x,y,info) - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x class(psb_s_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine s_vect_clone @@ -941,7 +973,7 @@ contains class(psb_s_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) @@ -959,7 +991,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) @@ -1019,7 +1051,7 @@ contains end function size_const function s_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1027,7 +1059,7 @@ contains end function s_vect_get_nrows function s_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1035,7 +1067,7 @@ contains end function s_vect_get_ncols function s_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1043,7 +1075,7 @@ contains end function s_vect_sizeof function s_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1052,18 +1084,18 @@ contains subroutine s_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(out) :: x class(psb_s_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_s_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1073,12 +1105,12 @@ contains subroutine s_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1088,7 +1120,7 @@ contains subroutine s_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1098,7 +1130,7 @@ contains subroutine s_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1109,7 +1141,7 @@ contains end subroutine s_vect_asb subroutine s_vect_sync(x) - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1177,12 +1209,12 @@ contains subroutine s_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1191,7 +1223,7 @@ contains subroutine s_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1201,7 +1233,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1217,12 +1249,12 @@ contains class(psb_s_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_s_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1232,7 +1264,7 @@ contains !!$ function s_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res @@ -1244,28 +1276,28 @@ contains !!$ end function s_vect_dot_v !!$ !!$ function s_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ real(psb_spk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res -!!$ +!!$ !!$ res = szero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function s_vect_dot_a -!!$ +!!$ !!$ subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ real(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1275,25 +1307,25 @@ contains !!$ !!$ subroutine s_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ real(psb_spk_), intent(in) :: x(:) !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ real(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine s_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine s_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1304,7 +1336,7 @@ contains !!$ !!$ subroutine s_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: x(:) !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1314,13 +1346,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine s_vect_mlt_a !!$ !!$ !!$ subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: y(:) !!$ real(psb_spk_), intent(in) :: x(:) @@ -1328,20 +1360,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine s_vect_mlt_a_2 !!$ !!$ subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ class(psb_s_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1355,12 +1387,12 @@ contains !!$ !!$ subroutine s_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: x(:) !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ class(psb_s_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1371,16 +1403,16 @@ contains !!$ !!$ subroutine s_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: y(:) !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1388,36 +1420,36 @@ contains !!$ !!$ subroutine s_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ real(psb_spk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine s_vect_scal !!$ !!$ !!$ function s_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = szero !!$ end if !!$ !!$ end function s_vect_nrm2 -!!$ +!!$ !!$ function s_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = szero @@ -1426,12 +1458,12 @@ contains !!$ end function s_vect_amax !!$ !!$ function s_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = szero diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index 6dd242cc..350e7034 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,14 +27,14 @@ ! 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 +! 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 @@ -43,7 +43,7 @@ ! ! module psb_z_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_z_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_z_base_vect_type - !! The psb_z_base_vect_type + !! The psb_z_base_vect_type !! defines a middle level complex(psb_dpk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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 @@ -61,9 +61,9 @@ module psb_z_base_vect_mod !! sparse matrix types. !! type psb_z_base_vect_type - !> Values. + !> Values. complex(psb_dpk_), allocatable :: v(:) - complex(psb_dpk_), allocatable :: combuf(:) + complex(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_z_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => z_base_ins_a procedure, pass(x) :: ins_v => z_base_ins_v @@ -93,7 +93,7 @@ module psb_z_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => z_base_sync procedure, pass(x) :: is_host => z_base_is_host @@ -130,7 +130,7 @@ module psb_z_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => z_base_gthab procedure, pass(x) :: gthzv => z_base_gthzv @@ -164,6 +164,12 @@ module psb_z_base_vect_mod procedure, pass(z) :: mlt_av => z_base_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => z_base_div_v + procedure, pass(z) :: div_a2 => z_base_div_a2 + generic, public :: div => div_v, div_a2 + ! ! Scaling and norms ! procedure, pass(x) :: scal => z_base_scal @@ -183,11 +189,11 @@ module psb_z_base_vect_mod end interface psb_z_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +206,11 @@ contains 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. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +220,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +232,20 @@ contains !! subroutine z_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: this(:) class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine z_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +253,11 @@ contains !> Function bld_mn: !! \memberof psb_z_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine z_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +266,15 @@ contains call x%asb(n,info) 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. + !! \param n size to be allocated. !! subroutine z_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +283,24 @@ contains call x%asb(n,info) 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 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 + 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) - + end subroutine z_base_all !> Function base_mold: @@ -306,11 +312,11 @@ contains subroutine z_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -320,21 +326,21 @@ contains ! !> Function base_ins: !! \memberof psb_z_base_vect_type - !! \brief Insert coefficients. + !! \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 @@ -344,7 +350,7 @@ contains ! subroutine z_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +360,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -376,7 +382,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +400,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +409,7 @@ contains subroutine z_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +419,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + 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,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +442,14 @@ contains ! subroutine z_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=zzero call x%set_host() end subroutine z_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +458,20 @@ contains !> Function base_asb: !! \memberof psb_z_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine z_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +488,20 @@ contains !> Function base_asb: !! \memberof psb_z_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine z_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +514,39 @@ contains !> Function base_free: !! \memberof psb_z_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine z_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine z_base_free - + ! !> Function base_free_buffer: !! \memberof psb_z_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine z_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +561,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine z_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +581,13 @@ contains !> Function base_free_comid: !! \memberof psb_z_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine z_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +599,77 @@ contains ! ! 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. - !! + !! ! subroutine z_base_sync(x) - implicit none + 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. - !! + !! ! subroutine z_base_set_host(x) - implicit none + 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. - !! + !! ! subroutine z_base_set_dev(x) - implicit none + 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. - !! + !! ! subroutine z_base_set_sync(x) - implicit none + 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 . - !! + !! ! function z_base_is_dev(x) result(res) - implicit none + 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 . - !! + !! ! function z_base_is_host(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +680,10 @@ contains !> Function base_is_sync !! \memberof psb_z_base_vect_type !! \brief Is vector on sync . - !! + !! ! function z_base_is_sync(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +692,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_z_base_vect_type !! \brief Number of entries - !! + !! ! function z_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +714,13 @@ contains !> Function base_get_sizeof !! \memberof psb_z_base_vect_type !! \brief Size in bytes - !! + !! ! function z_base_sizeof(x) result(res) - implicit none + 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() @@ -724,14 +730,14 @@ contains !> Function base_get_fmt !! \memberof psb_z_base_vect_type !! \brief Format - !! + !! ! function z_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function z_base_get_fmt - + ! ! @@ -740,7 +746,7 @@ contains !! \memberof psb_z_base_vect_type !! \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(:) @@ -748,21 +754,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + 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 + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function z_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +777,18 @@ contains !! \param val The value to set !! subroutine z_base_set_scal(x,val,first,last) - implicit none + 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_) :: info, first_, last_ 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() x%v(first_:last_) = val call x%set_host() @@ -794,14 +800,14 @@ contains !> Function base_set_vect !! \memberof psb_z_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine z_base_set_vect(x,val,first,last) - implicit none + 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_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +815,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +835,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine z_base_absval1(x) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +847,21 @@ contains end subroutine z_base_absval1 subroutine z_base_absval2(x,y) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x + 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 + 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 - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_z_base_vect_type @@ -864,12 +870,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function z_base_dot_v(n,x,y) result(res) - implicit none + 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. @@ -898,19 +904,19 @@ contains !! \param y(:) The array to be multiplied by !! function z_base_dot_a(n,x,y) result(res) - implicit none + 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. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +931,13 @@ contains !! subroutine z_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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) @@ -939,7 +945,7 @@ contains end subroutine z_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +959,20 @@ contains !! subroutine z_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + 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 - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +990,10 @@ contains !! subroutine z_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1011,7 @@ contains !! subroutine z_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:) class(psb_z_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1020,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1041,7 @@ contains !! subroutine z_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:) complex(psb_dpk_), intent(in) :: x(:) @@ -1043,58 +1049,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + 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 + if (alpha == zzero) then + if (beta == zone) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == zone) then - if (beta == zzero) then - do i=1, n + if (alpha == zone) then + if (beta == zzero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == zone) then - do i=1, n + else if (beta == zone) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + 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 - do i=1, n + else if (alpha == -zone) then + if (beta == zzero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == zone) then - do i=1, n + else if (beta == zone) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == zzero) then - do i=1, n + if (beta == zzero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == zone) then - do i=1, n + else if (beta == zone) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1124,12 @@ contains subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1139,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1154,12 @@ contains subroutine z_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1170,12 @@ contains subroutine z_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + 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_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1183,57 @@ contains 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 + !! + 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 ! - ! Simple scaling + !> Function base_div_a2 + !! \memberof psb_z_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y + !! \param x(:) The array to be multiplied 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)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine z_base_div_a2 + + + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_z_base_vect_type @@ -1189,17 +1242,17 @@ contains !! subroutine z_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x complex(psb_dpk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine z_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,28 +1261,28 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function z_base_nrm2(n,x) result(res) - implicit none + 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 function z_base_amax(n,x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) @@ -1241,17 +1294,17 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function z_base_asum(n,x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function z_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1319,18 @@ contains !! \param beta subroutine z_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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 @@ -1286,28 +1339,28 @@ contains !! \param idx(:) indices subroutine z_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,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. + ! New comm internals impl. ! subroutine z_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_z_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1373,22 @@ contains !> 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 - + 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 + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1398,7 @@ contains subroutine z_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1409,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_z_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1418,20 @@ contains !! \param idx(:) indices subroutine z_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_z_base_vect_type @@ -1387,14 +1440,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine z_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, 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() @@ -1403,12 +1456,12 @@ contains subroutine z_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n 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() @@ -1417,14 +1470,14 @@ contains subroutine z_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: beta class(psb_z_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1449,22 +1502,22 @@ module psb_z_base_multivect_mod use psb_z_base_vect_mod !> \namespace psb_base_mod \class psb_z_base_vect_type - !! The psb_z_base_vect_type + !! The psb_z_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for 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. !! - private + private public :: psb_z_base_multivect, psb_z_base_multivect_type type psb_z_base_multivect_type - !> Values. + !> Values. complex(psb_dpk_), allocatable :: v(:,:) - complex(psb_dpk_), allocatable :: combuf(:) + complex(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +1531,7 @@ module psb_z_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => z_base_mlv_ins procedure, pass(x) :: zero => z_base_mlv_zero @@ -1489,7 +1542,7 @@ module psb_z_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => z_base_mlv_sync procedure, pass(x) :: is_host => z_base_mlv_is_host @@ -1562,7 +1615,7 @@ module psb_z_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => z_base_mlv_gthab procedure, pass(x) :: gthzv => z_base_mlv_gthzv @@ -1584,7 +1637,7 @@ module psb_z_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +1656,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +1683,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +1698,7 @@ contains !> Function bld_n: !! \memberof psb_z_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine z_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +1715,13 @@ contains !! \memberof psb_z_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \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 + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +1739,7 @@ contains subroutine z_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 @@ -1700,21 +1753,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_z_base_multivect_type - !! \brief Insert coefficients. + !! \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 @@ -1724,7 +1777,7 @@ contains ! subroutine z_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +1787,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! 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 @@ -1756,7 +1809,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +1826,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +1841,7 @@ contains ! subroutine z_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=zzero @@ -1804,7 +1857,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_z_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +1866,7 @@ contains subroutine z_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +1883,20 @@ contains !> Function base_mlv_free: !! \memberof psb_z_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine z_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + 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 & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine z_base_mlv_free @@ -1853,15 +1906,15 @@ contains ! ! 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. - !! + !! ! subroutine z_base_mlv_sync(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_sync @@ -1870,10 +1923,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_z_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine z_base_mlv_set_host(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_set_host @@ -1882,10 +1935,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_z_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine z_base_mlv_set_dev(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_set_dev @@ -1894,10 +1947,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_z_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine z_base_mlv_set_sync(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_set_sync @@ -1906,10 +1959,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_z_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function z_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +1973,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_z_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function z_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +1987,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_z_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function z_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +1999,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_z_base_multivect_type !! \brief Number of entries - !! + !! ! function z_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2018,7 @@ contains end function z_base_mlv_get_nrows function z_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2031,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_z_base_multivect_type !! \brief Size in bytesa - !! + !! ! function z_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2047,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_z_base_multivect_type !! \brief Format - !! + !! ! function z_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function z_base_mlv_get_fmt @@ -2010,18 +2063,18 @@ contains !! \memberof psb_z_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function z_base_mlv_get_vect(x) result(res) - implicit none + 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 + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2082,7 @@ contains end function z_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2091,7 @@ contains !! \param val The value to set !! subroutine z_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val @@ -2051,16 +2104,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_z_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine z_base_mlv_set_vect(x,val) - implicit none + 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 + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2125,8 @@ contains end subroutine z_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_z_base_multivect_type @@ -2082,7 +2135,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function z_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_dpk_), allocatable :: res(:) @@ -2094,7 +2147,7 @@ contains ! ! 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). + ! 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 ! @@ -2123,7 +2176,7 @@ contains !! \param y(:) The array to be multiplied by !! function z_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2194,7 @@ contains end function z_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2209,7 @@ contains !! subroutine z_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + 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 @@ -2180,7 +2233,7 @@ contains end subroutine z_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2247,7 @@ contains !! subroutine z_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent(in) :: x(:,:) class(psb_z_base_multivect_type), intent(inout) :: y @@ -2230,10 +2283,10 @@ contains !! subroutine z_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2296,10 @@ contains subroutine z_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + 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 + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2316,7 @@ contains !! subroutine z_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:) class(psb_z_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2324,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2339,7 @@ contains !! subroutine z_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:,:) class(psb_z_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2366,7 @@ contains !! subroutine z_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:,:) complex(psb_dpk_), intent(in) :: x(:,:) @@ -2321,38 +2374,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 @@ -2373,12 +2426,12 @@ contains 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 + 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 + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +2442,7 @@ contains 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 + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +2457,39 @@ contains !!$ !!$ subroutine z_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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) !!$ use psi_serial_mod -!!$ implicit none +!!$ 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_), 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 + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_z_base_multivect_type @@ -2445,7 +2498,7 @@ contains !! subroutine z_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent (in) :: alpha @@ -2462,7 +2515,7 @@ contains !! \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 + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2484,7 +2537,7 @@ contains !! \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 + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2505,7 +2558,7 @@ contains !! \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 + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2528,7 +2581,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine z_base_mlv_absval1(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +2593,13 @@ contains end subroutine z_base_mlv_absval1 subroutine z_base_mlv_absval2(x,y) - implicit none + 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 + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) call y%absval() end if @@ -2555,15 +2608,15 @@ contains function z_base_mlv_use_buffer() result(res) - implicit none + 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 + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +2628,7 @@ contains subroutine z_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +2639,12 @@ contains subroutine z_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +2652,7 @@ contains subroutine z_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +2662,7 @@ contains subroutine z_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +2685,7 @@ contains !! \param beta subroutine z_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: alpha, beta, y(:) class(psb_z_base_multivect_type) :: x @@ -2648,7 +2701,7 @@ contains 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 @@ -2657,7 +2710,7 @@ contains !! \param idx(:) indices subroutine z_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: y(:) @@ -2670,7 +2723,7 @@ contains ! ! 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 @@ -2679,7 +2732,7 @@ contains !! \param idx(:) indices subroutine z_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: y(:) class(psb_z_base_multivect_type) :: x @@ -2696,7 +2749,7 @@ contains 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 @@ -2705,7 +2758,7 @@ contains !! \param idx(:) indices subroutine z_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: y(:,:) class(psb_z_base_multivect_type) :: x @@ -2722,17 +2775,17 @@ contains end subroutine z_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine z_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_z_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +2797,9 @@ contains end subroutine z_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_z_base_multivect_type @@ -2755,10 +2808,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine z_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:) class(psb_z_base_multivect_type) :: y @@ -2773,7 +2826,7 @@ contains subroutine z_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:,:) class(psb_z_base_multivect_type) :: y @@ -2788,7 +2841,7 @@ contains subroutine z_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex( psb_dpk_) :: beta, x(:) @@ -2800,14 +2853,14 @@ contains subroutine z_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n 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 + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +2869,18 @@ contains 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. - !! + !! ! subroutine z_base_mlv_device_wait() - implicit none - + implicit none + end subroutine z_base_mlv_device_wait 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 f6da1ded..b65ba18b 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 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 @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_z_vect_mod ! ! This module contains the definition of the psb_z_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_z_vect_mod @@ -43,7 +43,7 @@ module psb_z_vect_mod use psb_i_vect_mod type psb_z_vect_type - class(psb_z_base_vect_type), allocatable :: v + class(psb_z_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => z_vect_get_nrows procedure, pass(x) :: sizeof => z_vect_sizeof @@ -94,13 +94,16 @@ module psb_z_vect_mod procedure, pass(z) :: mlt_av => z_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => z_vect_div_v + procedure, pass(z) :: div_a2 => z_vect_div_a2 + generic, public :: div => div_v, div_a2 procedure, pass(x) :: scal => z_vect_scal procedure, pass(x) :: absval1 => z_vect_absval1 procedure, pass(x) :: absval2 => z_vect_absval2 generic, public :: absval => absval1, absval2 procedure, pass(x) :: nrm2 => z_vect_nrm2 procedure, pass(x) :: amax => z_vect_amax - procedure, pass(x) :: asum => z_vect_asum + procedure, pass(x) :: asum => z_vect_asum end type psb_z_vect_type public :: psb_z_vect @@ -122,7 +125,7 @@ module psb_z_vect_mod private :: z_vect_dot_v, z_vect_dot_a, z_vect_axpby_v, z_vect_axpby_a, & & z_vect_mlt_v, z_vect_mlt_a, z_vect_mlt_a_2, z_vect_mlt_v_2, & & z_vect_mlt_va, z_vect_mlt_av, z_vect_scal, z_vect_absval1, & - & z_vect_absval2, z_vect_nrm2, z_vect_amax, z_vect_asum + & z_vect_absval2, z_vect_nrm2, z_vect_amax, z_vect_asum @@ -141,11 +144,11 @@ module psb_z_vect_mod contains - subroutine psb_z_set_vect_default(v) - implicit none + subroutine psb_z_set_vect_default(v) + implicit none class(psb_z_base_vect_type), intent(in) :: v - if (allocated(psb_z_base_vect_default)) then + if (allocated(psb_z_base_vect_default)) then deallocate(psb_z_base_vect_default) end if allocate(psb_z_base_vect_default, mold=v) @@ -153,7 +156,7 @@ contains end subroutine psb_z_set_vect_default function psb_z_get_vect_default(v) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: v class(psb_z_base_vect_type), pointer :: res @@ -163,10 +166,10 @@ contains function psb_z_get_base_vect_default() result(res) - implicit none + implicit none class(psb_z_base_vect_type), pointer :: res - if (.not.allocated(psb_z_base_vect_default)) then + if (.not.allocated(psb_z_base_vect_default)) then allocate(psb_z_base_vect_type :: psb_z_base_vect_default) end if @@ -176,14 +179,14 @@ contains subroutine z_vect_clone(x,y,info) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine z_vect_clone @@ -198,7 +201,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) @@ -220,7 +223,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) @@ -241,7 +244,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) @@ -304,7 +307,7 @@ contains end function size_const function z_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -312,7 +315,7 @@ contains end function z_vect_get_nrows function z_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -320,7 +323,7 @@ contains end function z_vect_sizeof function z_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -329,7 +332,7 @@ contains subroutine z_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold @@ -338,12 +341,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_z_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -353,12 +356,12 @@ contains subroutine z_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -368,7 +371,7 @@ contains subroutine z_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -378,7 +381,7 @@ contains subroutine z_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -424,12 +427,12 @@ contains subroutine z_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -438,7 +441,7 @@ contains subroutine z_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -448,7 +451,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -459,7 +462,7 @@ contains subroutine z_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -469,7 +472,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -487,12 +490,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_z_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -503,7 +506,7 @@ contains subroutine z_vect_sync(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -512,7 +515,7 @@ contains end subroutine z_vect_sync subroutine z_vect_set_sync(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -521,7 +524,7 @@ contains end subroutine z_vect_set_sync subroutine z_vect_set_host(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -530,7 +533,7 @@ contains end subroutine z_vect_set_host subroutine z_vect_set_dev(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -539,7 +542,7 @@ contains end subroutine z_vect_set_dev function z_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x @@ -550,7 +553,7 @@ contains end function z_vect_is_sync function z_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x @@ -561,11 +564,11 @@ contains end function z_vect_is_host function z_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -573,7 +576,7 @@ contains function z_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_dpk_) :: res @@ -585,7 +588,7 @@ contains end function z_vect_dot_v function z_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -599,14 +602,14 @@ contains subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -616,7 +619,7 @@ contains subroutine z_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent(in) :: x(:) class(psb_z_vect_type), intent(inout) :: y @@ -631,10 +634,10 @@ contains subroutine z_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -645,7 +648,7 @@ contains subroutine z_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:) class(psb_z_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -661,7 +664,7 @@ contains subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:) complex(psb_dpk_), intent(in) :: x(:) @@ -669,7 +672,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -677,12 +680,12 @@ contains subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -696,12 +699,12 @@ contains subroutine z_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: x(:) class(psb_z_vect_type), intent(inout) :: y class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -712,12 +715,12 @@ contains subroutine z_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:) class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -727,9 +730,38 @@ contains end subroutine z_vect_mlt_va + subroutine z_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine z_vect_div_v + + subroutine z_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine z_vect_div_a2 + subroutine z_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x complex(psb_dpk_), intent (in) :: alpha @@ -749,19 +781,19 @@ contains class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine z_vect_absval2 function z_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = dzero @@ -770,12 +802,12 @@ contains end function z_vect_nrm2 function z_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = dzero @@ -784,12 +816,12 @@ contains end function z_vect_amax function z_vect_asum(n,x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%asum(n) else res = dzero @@ -812,7 +844,7 @@ module psb_z_multivect_mod !private type psb_z_multivect_type - class(psb_z_base_multivect_type), allocatable :: v + class(psb_z_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => z_vect_get_nrows procedure, pass(x) :: get_ncols => z_vect_get_ncols @@ -886,11 +918,11 @@ module psb_z_multivect_mod contains - subroutine psb_z_set_multivect_default(v) - implicit none + subroutine psb_z_set_multivect_default(v) + implicit none class(psb_z_base_multivect_type), intent(in) :: v - if (allocated(psb_z_base_multivect_default)) then + if (allocated(psb_z_base_multivect_default)) then deallocate(psb_z_base_multivect_default) end if allocate(psb_z_base_multivect_default, mold=v) @@ -898,7 +930,7 @@ contains end subroutine psb_z_set_multivect_default function psb_z_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: v class(psb_z_base_multivect_type), pointer :: res @@ -908,10 +940,10 @@ contains function psb_z_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_z_base_multivect_type), pointer :: res - if (.not.allocated(psb_z_base_multivect_default)) then + if (.not.allocated(psb_z_base_multivect_default)) then allocate(psb_z_base_multivect_type :: psb_z_base_multivect_default) end if @@ -921,14 +953,14 @@ contains subroutine z_vect_clone(x,y,info) - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x class(psb_z_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine z_vect_clone @@ -941,7 +973,7 @@ contains class(psb_z_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) @@ -959,7 +991,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) @@ -1019,7 +1051,7 @@ contains end function size_const function z_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1027,7 +1059,7 @@ contains end function z_vect_get_nrows function z_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1035,7 +1067,7 @@ contains end function z_vect_get_ncols function z_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1043,7 +1075,7 @@ contains end function z_vect_sizeof function z_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1052,18 +1084,18 @@ contains subroutine z_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(out) :: x class(psb_z_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_z_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1073,12 +1105,12 @@ contains subroutine z_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1088,7 +1120,7 @@ contains subroutine z_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1098,7 +1130,7 @@ contains subroutine z_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1109,7 +1141,7 @@ contains end subroutine z_vect_asb subroutine z_vect_sync(x) - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1177,12 +1209,12 @@ contains subroutine z_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1191,7 +1223,7 @@ contains subroutine z_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1201,7 +1233,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1217,12 +1249,12 @@ contains class(psb_z_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_z_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1232,7 +1264,7 @@ contains !!$ function z_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_dpk_) :: res @@ -1244,28 +1276,28 @@ contains !!$ end function z_vect_dot_v !!$ !!$ function z_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ complex(psb_dpk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_dpk_) :: res -!!$ +!!$ !!$ res = zzero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function z_vect_dot_a -!!$ +!!$ !!$ subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ complex(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1275,25 +1307,25 @@ contains !!$ !!$ subroutine z_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ complex(psb_dpk_), intent(in) :: x(:) !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ complex(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine z_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine z_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1304,7 +1336,7 @@ contains !!$ !!$ subroutine z_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: x(:) !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1314,13 +1346,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine z_vect_mlt_a !!$ !!$ !!$ subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: y(:) !!$ complex(psb_dpk_), intent(in) :: x(:) @@ -1328,20 +1360,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine z_vect_mlt_a_2 !!$ !!$ subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ class(psb_z_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1355,12 +1387,12 @@ contains !!$ !!$ subroutine z_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: x(:) !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ class(psb_z_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1371,16 +1403,16 @@ contains !!$ !!$ subroutine z_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: y(:) !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1388,36 +1420,36 @@ contains !!$ !!$ subroutine z_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ complex(psb_dpk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine z_vect_scal !!$ !!$ !!$ function z_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = dzero !!$ end if !!$ !!$ end function z_vect_nrm2 -!!$ +!!$ !!$ function z_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = dzero @@ -1426,12 +1458,12 @@ contains !!$ end function z_vect_amax !!$ !!$ function z_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = dzero diff --git a/base/psblas/Makefile b/base/psblas/Makefile index bc583f17..6e1b1a70 100644 --- a/base/psblas/Makefile +++ b/base/psblas/Makefile @@ -10,25 +10,26 @@ OBJS= psb_ddot.o psb_damax.o psb_dasum.o psb_daxpby.o\ psb_snrm2.o psb_snrmi.o psb_sspmm.o psb_sspsm.o\ psb_camax.o psb_casum.o psb_caxpby.o psb_cdot.o \ psb_cnrm2.o psb_cnrmi.o psb_cspmm.o psb_cspsm.o \ - psb_cmlt_vect.o psb_dmlt_vect.o psb_zmlt_vect.o psb_smlt_vect.o + psb_cmlt_vect.o psb_dmlt_vect.o psb_zmlt_vect.o psb_smlt_vect.o\ + psb_cdiv_vect.o psb_ddiv_vect.o psb_zdiv_vect.o psb_sdiv_vect.o LIBDIR=.. INCDIR=.. MODDIR=../modules -FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) +FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) -lib: $(OBJS) +lib: $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) -#$(F90_PSDOBJS): $(MODS) +#$(F90_PSDOBJS): $(MODS) veryclean: clean /bin/rm -f $(LIBNAME) -clean: +clean: /bin/rm -f $(OBJS) $(LOCAL_MODS) veryclean: clean diff --git a/base/psblas/psb_cdiv_vect.f90 b/base/psblas/psb_cdiv_vect.f90 new file mode 100644 index 00000000..38c7ce6a --- /dev/null +++ b/base/psblas/psb_cdiv_vect.f90 @@ -0,0 +1,105 @@ +! +! 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 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. +! +! +! File: psb_cdiv_vect + +subroutine psb_cdiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cdiv_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cdiv_vect diff --git a/base/psblas/psb_ddiv_vect.f90 b/base/psblas/psb_ddiv_vect.f90 new file mode 100644 index 00000000..d9ab0203 --- /dev/null +++ b/base/psblas/psb_ddiv_vect.f90 @@ -0,0 +1,105 @@ +! +! 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 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. +! +! +! File: psb_ddiv_vect + +subroutine psb_ddiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_ddiv_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ddiv_vect diff --git a/base/psblas/psb_sdiv_vect.f90 b/base/psblas/psb_sdiv_vect.f90 new file mode 100644 index 00000000..99a1ce7c --- /dev/null +++ b/base/psblas/psb_sdiv_vect.f90 @@ -0,0 +1,105 @@ +! +! 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 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. +! +! +! File: psb_sdiv_vect + +subroutine psb_sdiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_sdiv_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sdiv_vect diff --git a/base/psblas/psb_zdiv_vect.f90 b/base/psblas/psb_zdiv_vect.f90 new file mode 100644 index 00000000..949cbf7d --- /dev/null +++ b/base/psblas/psb_zdiv_vect.f90 @@ -0,0 +1,105 @@ +! +! 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 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. +! +! +! File: psb_zdiv_vect + +subroutine psb_zdiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zdiv_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zdiv_vect diff --git a/test/kernel/vecoperation.f90 b/test/kernel/vecoperation.f90 index 732a4708..e9cc88a8 100644 --- a/test/kernel/vecoperation.f90 +++ b/test/kernel/vecoperation.f90 @@ -55,6 +55,7 @@ program vecoperation integer(psb_lpk_), allocatable :: myidx(:) real(psb_dpk_) :: zt(1), dotresult, norm2, norm1, norminf character(len=20) :: name,ch_err,readinput + real(psb_dpk_), allocatable :: vx(:), vy(:) info=psb_success_ @@ -139,6 +140,12 @@ program vecoperation t2 = psb_wtime() - t1 if (iam == psb_root_) write(psb_out_unit,'("Overall vector creation time : ",es12.5)')t2 + if (iam == psb_root_) then + vx = x%get_vect() + write(psb_out_unit,'("x = ",es12.1)')vx(:) + vy = y%get_vect() + write(psb_out_unit,'("y = ",es12.1)')vy(:) + end if ! ! Vector operations @@ -150,8 +157,33 @@ program vecoperation norminf = psb_normi(x,desc_a,info) if (iam == psb_root_) write(psb_out_unit,'("\|x\|_inf : ",es12.5," \|x\|_1 :",es12.5," \|x\|_2",es12.5)')norminf,norm1,norm2 call psb_geaxpby(1.0_psb_dpk_, x, 1.0_psb_dpk_, y, desc_a, info) ! \alpha x + \beta y + + if (iam == psb_root_) then + vx = x%get_vect() + write(psb_out_unit,'("x = ",es12.1)')vx(:) + vy = y%get_vect() + write(psb_out_unit,'("y = ",es12.1)')vy(:) + end if + call psb_gemlt(x,y,desc_a,info) + if (iam == psb_root_) then + vx = x%get_vect() + write(psb_out_unit,'("x = ",es12.1)')vx(:) + vy = y%get_vect() + write(psb_out_unit,'("y = ",es12.1)')vy(:) + end if + + call psb_gediv(x,y,desc_a,info) + + if (iam == psb_root_) then + vx = x%get_vect() + write(psb_out_unit,'("x = ",es12.1)')vx(:) + vy = y%get_vect() + write(psb_out_unit,'("y = ",es12.1)')vy(:) + end if + + !