diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index a4b78538..52b909ab 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -479,4 +479,5 @@ module psb_c_psblas_mod end subroutine psb_cinv_vect_check 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 c605e9a8..1407cbb6 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -479,4 +479,16 @@ module psb_d_psblas_mod end subroutine psb_dinv_vect_check end interface + interface psb_gecmp + subroutine psb_dcmp_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dcmp_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 8abcbaf9..e1a62206 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -479,4 +479,16 @@ module psb_s_psblas_mod end subroutine psb_sinv_vect_check end interface + interface psb_gecmp + subroutine psb_scmp_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_scmp_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 d284a524..ee8f44e9 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -479,4 +479,5 @@ module psb_z_psblas_mod end subroutine psb_zinv_vect_check 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 6bf54df0..0eca0832 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -187,6 +187,7 @@ module psb_c_base_vect_mod procedure, pass(x) :: amax => c_base_amax procedure, pass(x) :: asum => c_base_asum + end type psb_c_base_vect_type public :: psb_c_base_vect @@ -1401,8 +1402,6 @@ contains end subroutine c_base_inv_a2_check - - ! ! Simple scaling ! diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index f4fc0873..bc65eb96 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -135,6 +135,11 @@ module psb_c_vect_mod & c_vect_absval2, c_vect_nrm2, c_vect_amax, c_vect_asum +! @NOTCPLXS@ +! @NOTINTS@ +! private :: c_vect_cmp_a2, c_vect_cmp_v2 +! @NOTINTE@ +! @NOTCPLXE@ class(psb_c_base_vect_type), allocatable, target,& & save, private :: psb_c_base_vect_default @@ -855,6 +860,7 @@ contains end subroutine c_vect_inv_a2_check + subroutine c_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 46ec3413..dc0c56aa 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -187,6 +187,13 @@ module psb_d_base_vect_mod procedure, pass(x) :: amax => d_base_amax procedure, pass(x) :: asum => d_base_asum + ! + ! Comparison and mask operation + ! + procedure, pass(z) :: cmp_a2 => d_base_cmp_a2 + procedure, pass(z) :: cmp_v2 => d_base_cmp_v2 + generic, public :: cmp => cmp_a2,cmp_v2 + end type psb_d_base_vect_type public :: psb_d_base_vect @@ -1401,8 +1408,58 @@ contains end subroutine d_base_inv_a2_check + ! + !> Function base_inv_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine d_base_cmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_dpk_ + else + z%v(i) = 0_psb_dpk_ + end if + end do + info = 0 + end subroutine d_base_cmp_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_d_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine d_base_cmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + info = 0 + if (x%is_dev()) call x%sync() + call z%cmp(x%v,c,info) + end subroutine d_base_cmp_v2 ! ! Simple scaling ! diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 4c74b842..be322f9c 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -111,6 +111,9 @@ module psb_d_vect_mod procedure, pass(x) :: nrm2 => d_vect_nrm2 procedure, pass(x) :: amax => d_vect_amax procedure, pass(x) :: asum => d_vect_asum + procedure, pass(z) :: cmp_a2 => d_vect_cmp_a2 + procedure, pass(z) :: cmp_v2 => d_vect_cmp_v2 + generic, public :: cmp => cmp_a2, cmp_v2 end type psb_d_vect_type public :: psb_d_vect @@ -135,6 +138,11 @@ module psb_d_vect_mod & d_vect_absval2, d_vect_nrm2, d_vect_amax, d_vect_asum +! @NOTCPLXS@ +! @NOTINTS@ +! private :: d_vect_cmp_a2, d_vect_cmp_v2 +! @NOTINTE@ +! @NOTCPLXE@ class(psb_d_base_vect_type), allocatable, target,& & save, private :: psb_d_base_vect_default @@ -855,6 +863,34 @@ contains end subroutine d_vect_inv_a2_check + subroutine d_vect_cmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%cmp(x,c,info) + + end subroutine d_vect_cmp_a2 + + subroutine d_vect_cmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%cmp(x%v,c,info) + + end subroutine d_vect_cmp_v2 + subroutine d_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/modules/serial/psb_i_base_vect_mod.f90 b/base/modules/serial/psb_i_base_vect_mod.f90 index 06871cb4..438a10ae 100644 --- a/base/modules/serial/psb_i_base_vect_mod.f90 +++ b/base/modules/serial/psb_i_base_vect_mod.f90 @@ -142,6 +142,7 @@ module psb_i_base_vect_mod + end type psb_i_base_vect_type public :: psb_i_base_vect diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index d3aaa48e..7fb233f8 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -98,6 +98,11 @@ module psb_i_vect_mod & i_vect_set_dev, i_vect_set_sync +! @NOTCPLXS@ +! @NOTINTS@ +! private :: i_vect_cmp_a2, i_vect_cmp_v2 +! @NOTINTE@ +! @NOTCPLXE@ class(psb_i_base_vect_type), allocatable, target,& & save, private :: psb_i_base_vect_default diff --git a/base/modules/serial/psb_l_base_vect_mod.f90 b/base/modules/serial/psb_l_base_vect_mod.f90 index 37bdf485..05275759 100644 --- a/base/modules/serial/psb_l_base_vect_mod.f90 +++ b/base/modules/serial/psb_l_base_vect_mod.f90 @@ -143,6 +143,7 @@ module psb_l_base_vect_mod + end type psb_l_base_vect_type public :: psb_l_base_vect diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index ece6ee66..3a955752 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -99,6 +99,11 @@ module psb_l_vect_mod & l_vect_set_dev, l_vect_set_sync +! @NOTCPLXS@ +! @NOTINTS@ +! private :: l_vect_cmp_a2, l_vect_cmp_v2 +! @NOTINTE@ +! @NOTCPLXE@ class(psb_l_base_vect_type), allocatable, target,& & save, private :: psb_l_base_vect_default diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 3c68d56f..450fdd29 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -187,6 +187,13 @@ module psb_s_base_vect_mod procedure, pass(x) :: amax => s_base_amax procedure, pass(x) :: asum => s_base_asum + ! + ! Comparison and mask operation + ! + procedure, pass(z) :: cmp_a2 => s_base_cmp_a2 + procedure, pass(z) :: cmp_v2 => s_base_cmp_v2 + generic, public :: cmp => cmp_a2,cmp_v2 + end type psb_s_base_vect_type public :: psb_s_base_vect @@ -1401,8 +1408,58 @@ contains end subroutine s_base_inv_a2_check + ! + !> Function base_inv_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine s_base_cmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_spk_ + else + z%v(i) = 0_psb_spk_ + end if + end do + info = 0 + end subroutine s_base_cmp_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_s_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine s_base_cmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + info = 0 + if (x%is_dev()) call x%sync() + call z%cmp(x%v,c,info) + end subroutine s_base_cmp_v2 ! ! Simple scaling ! diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 38478c43..c1f71208 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -111,6 +111,9 @@ module psb_s_vect_mod procedure, pass(x) :: nrm2 => s_vect_nrm2 procedure, pass(x) :: amax => s_vect_amax procedure, pass(x) :: asum => s_vect_asum + procedure, pass(z) :: cmp_a2 => s_vect_cmp_a2 + procedure, pass(z) :: cmp_v2 => s_vect_cmp_v2 + generic, public :: cmp => cmp_a2, cmp_v2 end type psb_s_vect_type public :: psb_s_vect @@ -135,6 +138,11 @@ module psb_s_vect_mod & s_vect_absval2, s_vect_nrm2, s_vect_amax, s_vect_asum +! @NOTCPLXS@ +! @NOTINTS@ +! private :: s_vect_cmp_a2, s_vect_cmp_v2 +! @NOTINTE@ +! @NOTCPLXE@ class(psb_s_base_vect_type), allocatable, target,& & save, private :: psb_s_base_vect_default @@ -855,6 +863,34 @@ contains end subroutine s_vect_inv_a2_check + subroutine s_vect_cmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%cmp(x,c,info) + + end subroutine s_vect_cmp_a2 + + subroutine s_vect_cmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%cmp(x%v,c,info) + + end subroutine s_vect_cmp_v2 + subroutine s_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index b87e16a6..808d9d4f 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -187,6 +187,7 @@ module psb_z_base_vect_mod procedure, pass(x) :: amax => z_base_amax procedure, pass(x) :: asum => z_base_asum + end type psb_z_base_vect_type public :: psb_z_base_vect @@ -1401,8 +1402,6 @@ contains end subroutine z_base_inv_a2_check - - ! ! Simple scaling ! diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index be48d0db..e9d5e1dd 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -135,6 +135,11 @@ module psb_z_vect_mod & z_vect_absval2, z_vect_nrm2, z_vect_amax, z_vect_asum +! @NOTCPLXS@ +! @NOTINTS@ +! private :: z_vect_cmp_a2, z_vect_cmp_v2 +! @NOTINTE@ +! @NOTCPLXE@ class(psb_z_base_vect_type), allocatable, target,& & save, private :: psb_z_base_vect_default @@ -855,6 +860,7 @@ contains end subroutine z_vect_inv_a2_check + subroutine z_vect_scal(alpha, x) use psi_serial_mod implicit none diff --git a/base/psblas/Makefile b/base/psblas/Makefile index 29d78acc..1feb2e78 100644 --- a/base/psblas/Makefile +++ b/base/psblas/Makefile @@ -13,6 +13,7 @@ OBJS= psb_ddot.o psb_damax.o psb_dasum.o psb_daxpby.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\ psb_cinv_vect.o psb_dinv_vect.o psb_zinv_vect.o psb_sinv_vect.o\ + psb_dcmp_vect.o psb_scmp_vect.o LIBDIR=.. INCDIR=.. diff --git a/base/psblas/psb_dcmp_vect.f90 b/base/psblas/psb_dcmp_vect.f90 new file mode 100644 index 00000000..bd5ae706 --- /dev/null +++ b/base/psblas/psb_dcmp_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_dcmp_vect + +subroutine psb_dcmp_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dcmp_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: c + 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_cmp_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(z%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,z%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 z%cmp(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dcmp_vect diff --git a/base/psblas/psb_scmp_vect.f90 b/base/psblas/psb_scmp_vect.f90 new file mode 100644 index 00000000..7aafd9ef --- /dev/null +++ b/base/psblas/psb_scmp_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_scmp_vect + +subroutine psb_scmp_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_scmp_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: c + 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_cmp_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(z%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,z%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 z%cmp(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_scmp_vect diff --git a/test/kernel/vecoperation.f90 b/test/kernel/vecoperation.f90 index a76049cf..02039033 100644 --- a/test/kernel/vecoperation.f90 +++ b/test/kernel/vecoperation.f90 @@ -56,6 +56,7 @@ program vecoperation real(psb_dpk_) :: zt(1), dotresult, norm2, norm1, norminf character(len=20) :: name,ch_err,readinput real(psb_dpk_), allocatable :: vx(:), vy(:), vz(:) + real(psb_dpk_) :: c info=psb_success_ @@ -194,7 +195,18 @@ program vecoperation vx = x%get_vect() write(psb_out_unit,'("x = ",es12.1)')vx(:) vz = z%get_vect() - write(psb_out_unit,'("z = ",es12.1)')vy(:) + write(psb_out_unit,'("z = ",es12.1)')vz(:) + end if + + c = 1.0/2.0; + call psb_gecmp(x,c,z,desc_a,info); + + if (iam == psb_root_) then + write(psb_out_unit,'("|z(i)| >=",es12.1)')c + vx = x%get_vect() + write(psb_out_unit,'("x = ",es12.1)')vx(:) + vz = z%get_vect() + write(psb_out_unit,'("z = ",es12.1)')vz(:) end if !