From fd89f2f1bfbf35e33e70693394eae38ca39e93dd Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Wed, 26 Feb 2020 19:34:14 +0100 Subject: [PATCH] Added psb_gescal subroutine to entrywise scale distributed vector with C interface --- 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 | 55 ++++++++++++- base/modules/serial/psb_c_vect_mod.F90 | 33 +++++++- base/modules/serial/psb_d_base_vect_mod.f90 | 55 ++++++++++++- base/modules/serial/psb_d_vect_mod.F90 | 33 +++++++- base/modules/serial/psb_s_base_vect_mod.f90 | 55 ++++++++++++- base/modules/serial/psb_s_vect_mod.F90 | 33 +++++++- base/modules/serial/psb_z_base_vect_mod.f90 | 55 ++++++++++++- base/modules/serial/psb_z_vect_mod.F90 | 33 +++++++- base/psblas/psb_caxpby.f90 | 87 ++++++++++++++++++++- base/psblas/psb_daxpby.f90 | 87 ++++++++++++++++++++- base/psblas/psb_saxpby.f90 | 87 ++++++++++++++++++++- base/psblas/psb_zaxpby.f90 | 87 ++++++++++++++++++++- cbind/base/psb_c_cbase.h | 1 + cbind/base/psb_c_dbase.h | 1 + cbind/base/psb_c_psblas_cbind_mod.f90 | 36 +++++++++ cbind/base/psb_c_sbase.h | 1 + cbind/base/psb_c_zbase.h | 1 + cbind/base/psb_d_psblas_cbind_mod.f90 | 36 +++++++++ cbind/base/psb_s_psblas_cbind_mod.f90 | 36 +++++++++ cbind/base/psb_z_psblas_cbind_mod.f90 | 36 +++++++++ 24 files changed, 880 insertions(+), 12 deletions(-) diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index f5fabd1e..d20e1a48 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -564,6 +564,17 @@ module psb_c_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_caddconst_vect end interface + interface psb_gescal + subroutine psb_cscal_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type, psb_spk_ + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_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_cscal_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 18311e0d..53cbda43 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -575,6 +575,17 @@ module psb_d_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_daddconst_vect end interface + interface psb_gescal + subroutine psb_dscal_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_dscal_vect + end interface interface psb_mask subroutine psb_dmask_vect(c,x,m,t,desc_a,info) diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index 4a1ef212..80f1d19a 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -575,6 +575,17 @@ module psb_s_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_saddconst_vect end interface + interface psb_gescal + subroutine psb_sscal_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_sscal_vect + end interface interface psb_mask subroutine psb_smask_vect(c,x,m,t,desc_a,info) diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index fa7ec1b7..94d31e00 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -564,6 +564,17 @@ module psb_z_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_zaddconst_vect end interface + interface psb_gescal + subroutine psb_zscal_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type, psb_dpk_ + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_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_zscal_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 4ea3227a..32f4e22e 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -183,7 +183,10 @@ module psb_c_base_vect_mod ! ! Scaling and norms ! - procedure, pass(x) :: scal => c_base_scal + procedure, pass(x) :: scal_v => c_base_scal + procedure, pass(z) :: scal_v2 => c_base_scal_v2 + procedure, pass(z) :: scal_a2 => c_base_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => c_base_absval1 procedure, pass(x) :: absval2 => c_base_absval2 generic, public :: absval => absval1, absval2 @@ -1541,6 +1544,56 @@ contains end subroutine c_base_scal + ! + !> Function base_scal_a2 + !! \memberof psb_c_base_vect_type + !! \brief Out of place scaling of the array x + !! \param x The array to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine c_base_scal_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i,n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + z%v(i) = c*x(i) + end do + info = 0 + + end subroutine c_base_scal_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_c_base_vect_type + !! \brief Out of place scaling of the vector x + !! \param x The vector to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine c_base_scal_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%scal(x%v,c,info) + end subroutine c_base_scal_v2 + ! ! Norms 1, 2 and infinity ! diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index d8eda729..afa2f0a9 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -107,7 +107,10 @@ module psb_c_vect_mod procedure, pass(y) :: inv_a2 => c_vect_inv_a2 procedure, pass(y) :: inv_a2_check => c_vect_inv_a2_check generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check - procedure, pass(x) :: scal => c_vect_scal + procedure, pass(x) :: scal_v => c_vect_scal + procedure, pass(z) :: scal_v2 => c_vect_scal_v2 + procedure, pass(z) :: scal_a2 => c_vect_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => c_vect_absval1 procedure, pass(x) :: absval2 => c_vect_absval2 generic, public :: absval => absval1, absval2 @@ -937,6 +940,34 @@ contains end subroutine c_vect_scal + subroutine c_vect_scal_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%scal(x,c,info) + + end subroutine c_vect_scal_a2 + + subroutine c_vect_scal_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%scal(x%v,c,info) + + end subroutine c_vect_scal_v2 + subroutine c_vect_absval1(x) class(psb_c_vect_type), intent(inout) :: x diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index b0d2d25e..733847ac 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -183,7 +183,10 @@ module psb_d_base_vect_mod ! ! Scaling and norms ! - procedure, pass(x) :: scal => d_base_scal + procedure, pass(x) :: scal_v => d_base_scal + procedure, pass(z) :: scal_v2 => d_base_scal_v2 + procedure, pass(z) :: scal_a2 => d_base_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => d_base_absval1 procedure, pass(x) :: absval2 => d_base_absval2 generic, public :: absval => absval1, absval2 @@ -1545,6 +1548,56 @@ contains end subroutine d_base_scal + ! + !> Function base_scal_a2 + !! \memberof psb_d_base_vect_type + !! \brief Out of place scaling of the array x + !! \param x The array to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine d_base_scal_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 + z%v(i) = c*x(i) + end do + info = 0 + + end subroutine d_base_scal_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_d_base_vect_type + !! \brief Out of place scaling of the vector x + !! \param x The vector to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine d_base_scal_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%scal(x%v,c,info) + end subroutine d_base_scal_v2 + ! ! Norms 1, 2 and infinity ! diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index b9be3d41..3b3011b9 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -107,7 +107,10 @@ module psb_d_vect_mod procedure, pass(y) :: inv_a2 => d_vect_inv_a2 procedure, pass(y) :: inv_a2_check => d_vect_inv_a2_check generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check - procedure, pass(x) :: scal => d_vect_scal + procedure, pass(x) :: scal_v => d_vect_scal + procedure, pass(z) :: scal_v2 => d_vect_scal_v2 + procedure, pass(z) :: scal_a2 => d_vect_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => d_vect_absval1 procedure, pass(x) :: absval2 => d_vect_absval2 generic, public :: absval => absval1, absval2 @@ -941,6 +944,34 @@ contains end subroutine d_vect_scal + subroutine d_vect_scal_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%scal(x,c,info) + + end subroutine d_vect_scal_a2 + + subroutine d_vect_scal_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%scal(x%v,c,info) + + end subroutine d_vect_scal_v2 + subroutine d_vect_absval1(x) class(psb_d_vect_type), intent(inout) :: x diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 35e92fef..12d9f381 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -183,7 +183,10 @@ module psb_s_base_vect_mod ! ! Scaling and norms ! - procedure, pass(x) :: scal => s_base_scal + procedure, pass(x) :: scal_v => s_base_scal + procedure, pass(z) :: scal_v2 => s_base_scal_v2 + procedure, pass(z) :: scal_a2 => s_base_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => s_base_absval1 procedure, pass(x) :: absval2 => s_base_absval2 generic, public :: absval => absval1, absval2 @@ -1545,6 +1548,56 @@ contains end subroutine s_base_scal + ! + !> Function base_scal_a2 + !! \memberof psb_s_base_vect_type + !! \brief Out of place scaling of the array x + !! \param x The array to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine s_base_scal_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 + z%v(i) = c*x(i) + end do + info = 0 + + end subroutine s_base_scal_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_s_base_vect_type + !! \brief Out of place scaling of the vector x + !! \param x The vector to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine s_base_scal_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%scal(x%v,c,info) + end subroutine s_base_scal_v2 + ! ! Norms 1, 2 and infinity ! diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 0fda1f2a..62ef21c7 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -107,7 +107,10 @@ module psb_s_vect_mod procedure, pass(y) :: inv_a2 => s_vect_inv_a2 procedure, pass(y) :: inv_a2_check => s_vect_inv_a2_check generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check - procedure, pass(x) :: scal => s_vect_scal + procedure, pass(x) :: scal_v => s_vect_scal + procedure, pass(z) :: scal_v2 => s_vect_scal_v2 + procedure, pass(z) :: scal_a2 => s_vect_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => s_vect_absval1 procedure, pass(x) :: absval2 => s_vect_absval2 generic, public :: absval => absval1, absval2 @@ -941,6 +944,34 @@ contains end subroutine s_vect_scal + subroutine s_vect_scal_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%scal(x,c,info) + + end subroutine s_vect_scal_a2 + + subroutine s_vect_scal_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%scal(x%v,c,info) + + end subroutine s_vect_scal_v2 + subroutine s_vect_absval1(x) class(psb_s_vect_type), intent(inout) :: x diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index 0dfa42ca..502b7795 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -183,7 +183,10 @@ module psb_z_base_vect_mod ! ! Scaling and norms ! - procedure, pass(x) :: scal => z_base_scal + procedure, pass(x) :: scal_v => z_base_scal + procedure, pass(z) :: scal_v2 => z_base_scal_v2 + procedure, pass(z) :: scal_a2 => z_base_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => z_base_absval1 procedure, pass(x) :: absval2 => z_base_absval2 generic, public :: absval => absval1, absval2 @@ -1541,6 +1544,56 @@ contains end subroutine z_base_scal + ! + !> Function base_scal_a2 + !! \memberof psb_z_base_vect_type + !! \brief Out of place scaling of the array x + !! \param x The array to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine z_base_scal_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i,n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + z%v(i) = c*x(i) + end do + info = 0 + + end subroutine z_base_scal_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_z_base_vect_type + !! \brief Out of place scaling of the vector x + !! \param x The vector to be scaled + !! \param z The scaled vector z = c*x + !! \param c The scaling term + !! \param info return code + ! + subroutine z_base_scal_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%scal(x%v,c,info) + end subroutine z_base_scal_v2 + ! ! Norms 1, 2 and infinity ! diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 69684c66..7b01aba0 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -107,7 +107,10 @@ module psb_z_vect_mod procedure, pass(y) :: inv_a2 => z_vect_inv_a2 procedure, pass(y) :: inv_a2_check => z_vect_inv_a2_check generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check - procedure, pass(x) :: scal => z_vect_scal + procedure, pass(x) :: scal_v => z_vect_scal + procedure, pass(z) :: scal_v2 => z_vect_scal_v2 + procedure, pass(z) :: scal_a2 => z_vect_scal_a2 + generic, public :: scal => scal_v, scal_v2, scal_a2 procedure, pass(x) :: absval1 => z_vect_absval1 procedure, pass(x) :: absval2 => z_vect_absval2 generic, public :: absval => absval1, absval2 @@ -937,6 +940,34 @@ contains end subroutine z_vect_scal + subroutine z_vect_scal_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%scal(x,c,info) + + end subroutine z_vect_scal_a2 + + subroutine z_vect_scal_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%scal(x%v,c,info) + + end subroutine z_vect_scal_v2 + subroutine z_vect_absval1(x) class(psb_z_vect_type), intent(inout) :: x diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index 47217d61..280022b1 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -400,7 +400,7 @@ subroutine psb_caddconst_vect(x,b,z,desc_a,info) integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err - name='psb_c_cmp_vect' + name='psb_c_addconst_vect' if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -457,3 +457,88 @@ subroutine psb_caddconst_vect(x,b,z,desc_a,info) return end subroutine psb_caddconst_vect +! +! Subroutine: psb_cscal_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_c_vect_type) The input vector containing the entries of X +! c - complex,input The scalar used to add each component of X +! z - type(psb_c_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_cscal_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cscal_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_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_c_scal_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%scal(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cscal_vect diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 432da824..4bdb24a8 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -400,7 +400,7 @@ subroutine psb_daddconst_vect(x,b,z,desc_a,info) integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err - name='psb_d_cmp_vect' + name='psb_d_addconst_vect' if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -457,3 +457,88 @@ subroutine psb_daddconst_vect(x,b,z,desc_a,info) return end subroutine psb_daddconst_vect +! +! Subroutine: psb_dscal_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_d_vect_type) The input vector containing the entries of X +! c - real,input The scalar used to add each component of X +! z - type(psb_d_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_dscal_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dscal_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_scal_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%scal(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dscal_vect diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index 5d2e47a6..2d3be43e 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -400,7 +400,7 @@ subroutine psb_saddconst_vect(x,b,z,desc_a,info) integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err - name='psb_s_cmp_vect' + name='psb_s_addconst_vect' if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -457,3 +457,88 @@ subroutine psb_saddconst_vect(x,b,z,desc_a,info) return end subroutine psb_saddconst_vect +! +! Subroutine: psb_sscal_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_s_vect_type) The input vector containing the entries of X +! c - real,input The scalar used to add each component of X +! z - type(psb_s_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_sscal_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_sscal_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_scal_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%scal(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sscal_vect diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index 9eb60323..b2cd7a0e 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -400,7 +400,7 @@ subroutine psb_zaddconst_vect(x,b,z,desc_a,info) integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err - name='psb_z_cmp_vect' + name='psb_z_addconst_vect' if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -457,3 +457,88 @@ subroutine psb_zaddconst_vect(x,b,z,desc_a,info) return end subroutine psb_zaddconst_vect +! +! Subroutine: psb_zscal_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_z_vect_type) The input vector containing the entries of X +! c - complex,input The scalar used to add each component of X +! z - type(psb_z_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_zscal_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zscal_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_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_z_scal_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%scal(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zscal_vect diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index f55b2479..9ae6ef1f 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -72,6 +72,7 @@ psb_i_t psb_c_cgeinv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor psb_i_t psb_c_cgeabs(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *cdh); psb_i_t psb_c_cgecmp(psb_c_cvector *xh,psb_s_t ch,psb_c_cvector *zh,psb_c_descriptor *cdh); psb_i_t psb_c_cgeaddconst(psb_c_cvector *xh,psb_c_t bh,psb_c_cvector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_cgescal(psb_c_cvector *xh,psb_s_t ch,psb_c_cvector *zh,psb_c_descriptor *cdh); psb_s_t psb_c_cgenrm2_weight(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_descriptor *cdh); psb_s_t psb_c_cgenrm2_weightmask(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_cvector *idvh,psb_c_descriptor *cdh); #ifdef __cplusplus diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index 70d185aa..4e1b645e 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -72,6 +72,7 @@ psb_i_t psb_c_dgeinv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor psb_i_t psb_c_dgeabs(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_dgecmp(psb_c_dvector *xh,psb_d_t ch,psb_c_dvector *zh,psb_c_descriptor *cdh); psb_i_t psb_c_dgeaddconst(psb_c_dvector *xh,psb_d_t bh,psb_c_dvector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_dgescal(psb_c_dvector *xh,psb_d_t ch,psb_c_dvector *zh,psb_c_descriptor *cdh); psb_d_t psb_c_dgenrm2_weight(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_descriptor *cdh); psb_d_t psb_c_dgenrm2_weightmask(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_dvector *idvh,psb_c_descriptor *cdh); psb_i_t psb_c_dmask(psb_c_dvector *ch,psb_c_dvector *xh,psb_c_dvector *mh, bool t, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_psblas_cbind_mod.f90 b/cbind/base/psb_c_psblas_cbind_mod.f90 index dc9cdab5..608db58b 100644 --- a/cbind/base/psb_c_psblas_cbind_mod.f90 +++ b/cbind/base/psb_c_psblas_cbind_mod.f90 @@ -456,6 +456,42 @@ contains end function psb_c_cgeaddconst + function psb_c_cgescal(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_float_complex) :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gescal(xp,ch,zp,descp,info) + + res = info + + end function psb_c_cgescal + function psb_c_cgenrm2(xh,cdh) bind(c) result(res) implicit none diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index d1be1313..6aa4db18 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -72,6 +72,7 @@ psb_i_t psb_c_sgeinv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor psb_i_t psb_c_sgeabs(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_sgecmp(psb_c_svector *xh,psb_s_t ch,psb_c_svector *zh,psb_c_descriptor *cdh); psb_i_t psb_c_sgeaddconst(psb_c_svector *xh,psb_s_t bh,psb_c_svector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_sgescal(psb_c_svector *xh,psb_s_t ch,psb_c_svector *zh,psb_c_descriptor *cdh); psb_s_t psb_c_sgenrm2_weight(psb_c_svector *xh,psb_c_svector *wh,psb_c_descriptor *cdh); psb_s_t psb_c_sgenrm2_weightmask(psb_c_svector *xh,psb_c_svector *wh,psb_c_svector *idvh,psb_c_descriptor *cdh); psb_i_t psb_c_smask(psb_c_svector *ch,psb_c_svector *xh,psb_c_svector *mh, bool t, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index 0ab91e2c..c3c9e342 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -72,6 +72,7 @@ psb_i_t psb_c_zgeinv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor psb_i_t psb_c_zgeabs(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_zgecmp(psb_c_zvector *xh,psb_d_t ch,psb_c_zvector *zh,psb_c_descriptor *cdh); psb_i_t psb_c_zgeaddconst(psb_c_zvector *xh,psb_z_t bh,psb_c_zvector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_zgescal(psb_c_zvector *xh,psb_d_t ch,psb_c_zvector *zh,psb_c_descriptor *cdh); psb_d_t psb_c_zgenrm2_weight(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_descriptor *cdh); psb_d_t psb_c_zgenrm2_weightmask(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_zvector *idvh,psb_c_descriptor *cdh); #ifdef __cplusplus diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 4d0b6fed..6b0b7994 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -456,6 +456,42 @@ contains end function psb_c_dgeaddconst + function psb_c_dgescal(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_double) :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gescal(xp,ch,zp,descp,info) + + res = info + + end function psb_c_dgescal + function psb_c_dmask(ch,xh,mh,t,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index 4867e08f..057992f6 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -456,6 +456,42 @@ contains end function psb_c_sgeaddconst + function psb_c_sgescal(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_float) :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gescal(xp,ch,zp,descp,info) + + res = info + + end function psb_c_sgescal + function psb_c_smask(ch,xh,mh,t,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res diff --git a/cbind/base/psb_z_psblas_cbind_mod.f90 b/cbind/base/psb_z_psblas_cbind_mod.f90 index b2a8375a..b2506853 100644 --- a/cbind/base/psb_z_psblas_cbind_mod.f90 +++ b/cbind/base/psb_z_psblas_cbind_mod.f90 @@ -456,6 +456,42 @@ contains end function psb_c_zgeaddconst + function psb_c_zgescal(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_double_complex) :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gescal(xp,ch,zp,descp,info) + + res = info + + end function psb_c_zgescal + function psb_c_zgenrm2(xh,cdh) bind(c) result(res) implicit none