fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Added scaling vector routine

Browse Source
lambdaI
Cirdans-Home 4 years ago
parent be38c25c04
commit d05d3746ff
28 changed files with 1002 additions and 134 deletions
Show Stats Download Patch File Download Diff File

11
base/modules/psblas/psb_c_psblas_mod.F90
Unescape Escape View File

@ -608,6 +608,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
interface psb_nnz

11
base/modules/psblas/psb_d_psblas_mod.F90
Unescape Escape View File

@ -619,6 +619,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)

11
base/modules/psblas/psb_s_psblas_mod.F90
Unescape Escape View File

@ -619,6 +619,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)

11
base/modules/psblas/psb_z_psblas_mod.F90
Unescape Escape View File

@ -608,6 +608,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
interface psb_nnz

83
base/modules/serial/psb_c_base_vect_mod.F90
Unescape Escape View File

@ -191,7 +191,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
@ -272,7 +275,7 @@ contains
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -805,7 +808,7 @@ contains
call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect')
return
end if
if (.false.) then
if (.false.) then
res(1:isz) = x%v(1:isz)
else
!$omp parallel do private(i)
@ -813,7 +816,7 @@ contains
res(i) = x%v(i)
end do
end if
end function c_base_get_vect
!
@ -841,7 +844,7 @@ contains
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
!$omp parallel do private(i)
do i = first_, last_
do i = first_, last_
x%v(i) = val
end do
#else
@ -869,7 +872,7 @@ contains
if (.not.allocated(x%v)) then
call psb_realloc(size(val),x%v,info)
end if
first_ = 1
if (present(first)) first_ = max(1,first)
last_ = min(psb_size(x%v),first_+size(val)-1)
@ -923,7 +926,7 @@ contains
class(psb_c_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: i
if (allocated(x%v)) then
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
@ -1175,7 +1178,7 @@ contains
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
@ -1221,7 +1224,7 @@ contains
else
if (alpha == cone) then
if (beta == czero) then
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
z%v(i) = y(i)*x(i)
end do
@ -1686,7 +1689,57 @@ contains
end if
call x%set_host()
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
!
@ -1742,7 +1795,7 @@ contains
integer(psb_ipk_), intent(in) :: n
real(psb_spk_) :: res
integer(psb_ipk_) :: i
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
res=szero
@ -1969,7 +2022,7 @@ contains
z%v = x + b
#endif
info = 0
end subroutine c_base_addconst_a2
!
!> Function _base_addconst_v2
@ -2011,7 +2064,7 @@ contains
if (y%is_dev()) call y%sync()
x%v = real(y%v, kind=psb_spk_)
x%v = real(y%v, kind=psb_spk_)
call x%set_host()
@ -2019,7 +2072,7 @@ contains
return
end subroutine c_copy_to_real
subroutine c_copy_from_real(x,y,info)
use psi_serial_mod
use psb_s_base_vect_mod
@ -2042,7 +2095,7 @@ contains
call y%set_host()
end subroutine c_copy_from_real
end module psb_c_base_vect_mod

57
base/modules/serial/psb_c_vect_mod.F90
Unescape Escape View File

@ -58,7 +58,7 @@ module psb_c_vect_mod
procedure, pass(x) :: is_remote_build => c_vect_is_remote_build
procedure, pass(x) :: set_remote_build => c_vect_set_remote_build
procedure, pass(x) :: get_dupl => c_vect_get_dupl
procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: get_nrmv => c_vect_get_nrmv
procedure, pass(x) :: set_nrmv => c_vect_set_nrmv
procedure, pass(x) :: all => c_vect_all
@ -129,7 +129,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
@ -222,7 +225,7 @@ contains
x%nrmv = val
end subroutine c_vect_set_nrmv
function c_vect_is_remote_build(x) result(res)
implicit none
@ -242,7 +245,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine c_vect_set_remote_build
subroutine psb_c_set_vect_default(v)
implicit none
class(psb_c_base_vect_type), intent(in) :: v
@ -403,7 +406,7 @@ contains
call psb_erractionsave(err_act)
info = psb_err_alloc_dealloc_
if( allocated(y%v) ) &
if( allocated(y%v) ) &
& call y%v%copy_to_real(x%v,info)
return
@ -415,7 +418,7 @@ contains
class(psb_s_vect_type), intent(inout) :: x
class(psb_c_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
character(len=20) :: name='vec_to_real'
@ -423,11 +426,11 @@ contains
call psb_erractionsave(err_act)
info = psb_err_alloc_dealloc_
if( allocated(y%v) ) &
if( allocated(y%v) ) &
& call y%v%copy_from_real(x%v,info)
return
end subroutine c_vect_copy_from_real
@ -641,7 +644,7 @@ contains
allocate(tmp,stat=info,mold=psb_c_get_base_vect_default())
end if
if (allocated(x%v)) then
if (allocated(x%v%v)) then
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
@ -1105,6 +1108,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
@ -1198,7 +1229,7 @@ contains
! Temp vectors
type(psb_c_vect_type) :: wtemp
info = 0
info = 0
if( allocated(w%v) ) then
if (.not.present(aux)) then
allocate(wtemp%v, mold=w%v)
@ -1390,7 +1421,7 @@ module psb_c_multivect_mod
contains
function c_mvect_get_dupl(x) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: x
@ -1409,7 +1440,7 @@ contains
x%dupl = psb_dupl_def_
end if
end subroutine c_mvect_set_dupl
function c_mvect_is_remote_build(x) result(res)
implicit none
@ -1429,7 +1460,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine c_mvect_set_remote_build
subroutine psb_c_set_multivect_default(v)
implicit none

79
base/modules/serial/psb_d_base_vect_mod.F90
Unescape Escape View File

@ -188,7 +188,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
@ -276,7 +279,7 @@ contains
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -809,7 +812,7 @@ contains
call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect')
return
end if
if (.false.) then
if (.false.) then
res(1:isz) = x%v(1:isz)
else
!$omp parallel do private(i)
@ -817,7 +820,7 @@ contains
res(i) = x%v(i)
end do
end if
end function d_base_get_vect
!
@ -845,7 +848,7 @@ contains
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
!$omp parallel do private(i)
do i = first_, last_
do i = first_, last_
x%v(i) = val
end do
#else
@ -873,7 +876,7 @@ contains
if (.not.allocated(x%v)) then
call psb_realloc(size(val),x%v,info)
end if
first_ = 1
if (present(first)) first_ = max(1,first)
last_ = min(psb_size(x%v),first_+size(val)-1)
@ -927,7 +930,7 @@ contains
class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: i
if (allocated(x%v)) then
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
@ -1179,7 +1182,7 @@ contains
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
@ -1225,7 +1228,7 @@ contains
else
if (alpha == done) then
if (beta == dzero) then
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
z%v(i) = y(i)*x(i)
end do
@ -1690,7 +1693,57 @@ contains
end if
call x%set_host()
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
!
@ -1826,7 +1879,7 @@ contains
integer(psb_ipk_), intent(in) :: n
real(psb_dpk_) :: res
integer(psb_ipk_) :: i
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
res=dzero
@ -2145,7 +2198,7 @@ contains
z%v = x + b
#endif
info = 0
end subroutine d_base_addconst_a2
!
!> Function _base_addconst_v2
@ -2169,7 +2222,7 @@ contains
call z%addconst(x%v,b,info)
end subroutine d_base_addconst_v2
end module psb_d_base_vect_mod

49
base/modules/serial/psb_d_vect_mod.F90
Unescape Escape View File

@ -57,7 +57,7 @@ module psb_d_vect_mod
procedure, pass(x) :: is_remote_build => d_vect_is_remote_build
procedure, pass(x) :: set_remote_build => d_vect_set_remote_build
procedure, pass(x) :: get_dupl => d_vect_get_dupl
procedure, pass(x) :: set_dupl => d_vect_set_dupl
procedure, pass(x) :: set_dupl => d_vect_set_dupl
procedure, pass(x) :: get_nrmv => d_vect_get_nrmv
procedure, pass(x) :: set_nrmv => d_vect_set_nrmv
procedure, pass(x) :: all => d_vect_all
@ -123,7 +123,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
@ -223,7 +226,7 @@ contains
x%nrmv = val
end subroutine d_vect_set_nrmv
function d_vect_is_remote_build(x) result(res)
implicit none
@ -243,7 +246,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine d_vect_set_remote_build
subroutine psb_d_set_vect_default(v)
implicit none
class(psb_d_base_vect_type), intent(in) :: v
@ -602,7 +605,7 @@ contains
allocate(tmp,stat=info,mold=psb_d_get_base_vect_default())
end if
if (allocated(x%v)) then
if (allocated(x%v%v)) then
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
@ -1066,6 +1069,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
@ -1159,7 +1190,7 @@ contains
! Temp vectors
type(psb_d_vect_type) :: wtemp
info = 0
info = 0
if( allocated(w%v) ) then
if (.not.present(aux)) then
allocate(wtemp%v, mold=w%v)
@ -1423,7 +1454,7 @@ module psb_d_multivect_mod
contains
function d_mvect_get_dupl(x) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: x
@ -1442,7 +1473,7 @@ contains
x%dupl = psb_dupl_def_
end if
end subroutine d_mvect_set_dupl
function d_mvect_is_remote_build(x) result(res)
implicit none
@ -1462,7 +1493,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine d_mvect_set_remote_build
subroutine psb_d_set_multivect_default(v)
implicit none

12
base/modules/serial/psb_i_base_vect_mod.F90
Unescape Escape View File

@ -205,7 +205,7 @@ contains
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -738,7 +738,7 @@ contains
call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect')
return
end if
if (.false.) then
if (.false.) then
res(1:isz) = x%v(1:isz)
else
!$omp parallel do private(i)
@ -746,7 +746,7 @@ contains
res(i) = x%v(i)
end do
end if
end function i_base_get_vect
!
@ -774,7 +774,7 @@ contains
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
!$omp parallel do private(i)
do i = first_, last_
do i = first_, last_
x%v(i) = val
end do
#else
@ -802,7 +802,7 @@ contains
if (.not.allocated(x%v)) then
call psb_realloc(size(val),x%v,info)
end if
first_ = 1
if (present(first)) first_ = max(1,first)
last_ = min(psb_size(x%v),first_+size(val)-1)
@ -1009,7 +1009,7 @@ contains
end module psb_i_base_vect_mod

14
base/modules/serial/psb_i_vect_mod.F90
Unescape Escape View File

@ -56,7 +56,7 @@ module psb_i_vect_mod
procedure, pass(x) :: is_remote_build => i_vect_is_remote_build
procedure, pass(x) :: set_remote_build => i_vect_set_remote_build
procedure, pass(x) :: get_dupl => i_vect_get_dupl
procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: get_nrmv => i_vect_get_nrmv
procedure, pass(x) :: set_nrmv => i_vect_set_nrmv
procedure, pass(x) :: all => i_vect_all
@ -163,7 +163,7 @@ contains
x%nrmv = val
end subroutine i_vect_set_nrmv
function i_vect_is_remote_build(x) result(res)
implicit none
@ -183,7 +183,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine i_vect_set_remote_build
subroutine psb_i_set_vect_default(v)
implicit none
class(psb_i_base_vect_type), intent(in) :: v
@ -542,7 +542,7 @@ contains
allocate(tmp,stat=info,mold=psb_i_get_base_vect_default())
end if
if (allocated(x%v)) then
if (allocated(x%v%v)) then
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
@ -701,7 +701,7 @@ module psb_i_multivect_mod
contains
function i_mvect_get_dupl(x) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: x
@ -720,7 +720,7 @@ contains
x%dupl = psb_dupl_def_
end if
end subroutine i_mvect_set_dupl
function i_mvect_is_remote_build(x) result(res)
implicit none
@ -740,7 +740,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine i_mvect_set_remote_build
subroutine psb_i_set_multivect_default(v)
implicit none

12
base/modules/serial/psb_l_base_vect_mod.F90
Unescape Escape View File

@ -206,7 +206,7 @@ contains
class(psb_l_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -739,7 +739,7 @@ contains
call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect')
return
end if
if (.false.) then
if (.false.) then
res(1:isz) = x%v(1:isz)
else
!$omp parallel do private(i)
@ -747,7 +747,7 @@ contains
res(i) = x%v(i)
end do
end if
end function l_base_get_vect
!
@ -775,7 +775,7 @@ contains
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
!$omp parallel do private(i)
do i = first_, last_
do i = first_, last_
x%v(i) = val
end do
#else
@ -803,7 +803,7 @@ contains
if (.not.allocated(x%v)) then
call psb_realloc(size(val),x%v,info)
end if
first_ = 1
if (present(first)) first_ = max(1,first)
last_ = min(psb_size(x%v),first_+size(val)-1)
@ -1010,7 +1010,7 @@ contains
end module psb_l_base_vect_mod

14
base/modules/serial/psb_l_vect_mod.F90
Unescape Escape View File

@ -57,7 +57,7 @@ module psb_l_vect_mod
procedure, pass(x) :: is_remote_build => l_vect_is_remote_build
procedure, pass(x) :: set_remote_build => l_vect_set_remote_build
procedure, pass(x) :: get_dupl => l_vect_get_dupl
procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: get_nrmv => l_vect_get_nrmv
procedure, pass(x) :: set_nrmv => l_vect_set_nrmv
procedure, pass(x) :: all => l_vect_all
@ -164,7 +164,7 @@ contains
x%nrmv = val
end subroutine l_vect_set_nrmv
function l_vect_is_remote_build(x) result(res)
implicit none
@ -184,7 +184,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine l_vect_set_remote_build
subroutine psb_l_set_vect_default(v)
implicit none
class(psb_l_base_vect_type), intent(in) :: v
@ -543,7 +543,7 @@ contains
allocate(tmp,stat=info,mold=psb_l_get_base_vect_default())
end if
if (allocated(x%v)) then
if (allocated(x%v%v)) then
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
@ -702,7 +702,7 @@ module psb_l_multivect_mod
contains
function l_mvect_get_dupl(x) result(res)
implicit none
class(psb_l_multivect_type), intent(in) :: x
@ -721,7 +721,7 @@ contains
x%dupl = psb_dupl_def_
end if
end subroutine l_mvect_set_dupl
function l_mvect_is_remote_build(x) result(res)
implicit none
@ -741,7 +741,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine l_mvect_set_remote_build
subroutine psb_l_set_multivect_default(v)
implicit none

79
base/modules/serial/psb_s_base_vect_mod.F90
Unescape Escape View File

@ -188,7 +188,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
@ -276,7 +279,7 @@ contains
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -809,7 +812,7 @@ contains
call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect')
return
end if
if (.false.) then
if (.false.) then
res(1:isz) = x%v(1:isz)
else
!$omp parallel do private(i)
@ -817,7 +820,7 @@ contains
res(i) = x%v(i)
end do
end if
end function s_base_get_vect
!
@ -845,7 +848,7 @@ contains
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
!$omp parallel do private(i)
do i = first_, last_
do i = first_, last_
x%v(i) = val
end do
#else
@ -873,7 +876,7 @@ contains
if (.not.allocated(x%v)) then
call psb_realloc(size(val),x%v,info)
end if
first_ = 1
if (present(first)) first_ = max(1,first)
last_ = min(psb_size(x%v),first_+size(val)-1)
@ -927,7 +930,7 @@ contains
class(psb_s_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: i
if (allocated(x%v)) then
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
@ -1179,7 +1182,7 @@ contains
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
@ -1225,7 +1228,7 @@ contains
else
if (alpha == sone) then
if (beta == szero) then
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
z%v(i) = y(i)*x(i)
end do
@ -1690,7 +1693,57 @@ contains
end if
call x%set_host()
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
!
@ -1826,7 +1879,7 @@ contains
integer(psb_ipk_), intent(in) :: n
real(psb_spk_) :: res
integer(psb_ipk_) :: i
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
res=szero
@ -2145,7 +2198,7 @@ contains
z%v = x + b
#endif
info = 0
end subroutine s_base_addconst_a2
!
!> Function _base_addconst_v2
@ -2169,7 +2222,7 @@ contains
call z%addconst(x%v,b,info)
end subroutine s_base_addconst_v2
end module psb_s_base_vect_mod

49
base/modules/serial/psb_s_vect_mod.F90
Unescape Escape View File

@ -57,7 +57,7 @@ module psb_s_vect_mod
procedure, pass(x) :: is_remote_build => s_vect_is_remote_build
procedure, pass(x) :: set_remote_build => s_vect_set_remote_build
procedure, pass(x) :: get_dupl => s_vect_get_dupl
procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: get_nrmv => s_vect_get_nrmv
procedure, pass(x) :: set_nrmv => s_vect_set_nrmv
procedure, pass(x) :: all => s_vect_all
@ -123,7 +123,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
@ -223,7 +226,7 @@ contains
x%nrmv = val
end subroutine s_vect_set_nrmv
function s_vect_is_remote_build(x) result(res)
implicit none
@ -243,7 +246,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine s_vect_set_remote_build
subroutine psb_s_set_vect_default(v)
implicit none
class(psb_s_base_vect_type), intent(in) :: v
@ -602,7 +605,7 @@ contains
allocate(tmp,stat=info,mold=psb_s_get_base_vect_default())
end if
if (allocated(x%v)) then
if (allocated(x%v%v)) then
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
@ -1066,6 +1069,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
@ -1159,7 +1190,7 @@ contains
! Temp vectors
type(psb_s_vect_type) :: wtemp
info = 0
info = 0
if( allocated(w%v) ) then
if (.not.present(aux)) then
allocate(wtemp%v, mold=w%v)
@ -1423,7 +1454,7 @@ module psb_s_multivect_mod
contains
function s_mvect_get_dupl(x) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: x
@ -1442,7 +1473,7 @@ contains
x%dupl = psb_dupl_def_
end if
end subroutine s_mvect_set_dupl
function s_mvect_is_remote_build(x) result(res)
implicit none
@ -1462,7 +1493,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine s_mvect_set_remote_build
subroutine psb_s_set_multivect_default(v)
implicit none

83
base/modules/serial/psb_z_base_vect_mod.F90
Unescape Escape View File

@ -191,7 +191,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
@ -272,7 +275,7 @@ contains
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
integer(psb_ipk_) :: i
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
@ -805,7 +808,7 @@ contains
call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect')
return
end if
if (.false.) then
if (.false.) then
res(1:isz) = x%v(1:isz)
else
!$omp parallel do private(i)
@ -813,7 +816,7 @@ contains
res(i) = x%v(i)
end do
end if
end function z_base_get_vect
!
@ -841,7 +844,7 @@ contains
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
!$omp parallel do private(i)
do i = first_, last_
do i = first_, last_
x%v(i) = val
end do
#else
@ -869,7 +872,7 @@ contains
if (.not.allocated(x%v)) then
call psb_realloc(size(val),x%v,info)
end if
first_ = 1
if (present(first)) first_ = max(1,first)
last_ = min(psb_size(x%v),first_+size(val)-1)
@ -923,7 +926,7 @@ contains
class(psb_z_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: i
if (allocated(x%v)) then
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
@ -1175,7 +1178,7 @@ contains
info = 0
if (y%is_dev()) call y%sync()
n = min(size(y%v), size(x))
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
@ -1221,7 +1224,7 @@ contains
else
if (alpha == zone) then
if (beta == zzero) then
!$omp parallel do private(i)
!$omp parallel do private(i)
do i=1, n
z%v(i) = y(i)*x(i)
end do
@ -1686,7 +1689,57 @@ contains
end if
call x%set_host()
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
!
@ -1742,7 +1795,7 @@ contains
integer(psb_ipk_), intent(in) :: n
real(psb_dpk_) :: res
integer(psb_ipk_) :: i
if (x%is_dev()) call x%sync()
#if defined(OPENMP)
res=dzero
@ -1969,7 +2022,7 @@ contains
z%v = x + b
#endif
info = 0
end subroutine z_base_addconst_a2
!
!> Function _base_addconst_v2
@ -2011,7 +2064,7 @@ contains
if (y%is_dev()) call y%sync()
x%v = real(y%v, kind=psb_dpk_)
x%v = real(y%v, kind=psb_dpk_)
call x%set_host()
@ -2019,7 +2072,7 @@ contains
return
end subroutine z_copy_to_real
subroutine z_copy_from_real(x,y,info)
use psi_serial_mod
use psb_d_base_vect_mod
@ -2042,7 +2095,7 @@ contains
call y%set_host()
end subroutine z_copy_from_real
end module psb_z_base_vect_mod

57
base/modules/serial/psb_z_vect_mod.F90
Unescape Escape View File

@ -58,7 +58,7 @@ module psb_z_vect_mod
procedure, pass(x) :: is_remote_build => z_vect_is_remote_build
procedure, pass(x) :: set_remote_build => z_vect_set_remote_build
procedure, pass(x) :: get_dupl => z_vect_get_dupl
procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: get_nrmv => z_vect_get_nrmv
procedure, pass(x) :: set_nrmv => z_vect_set_nrmv
procedure, pass(x) :: all => z_vect_all
@ -129,7 +129,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
@ -222,7 +225,7 @@ contains
x%nrmv = val
end subroutine z_vect_set_nrmv
function z_vect_is_remote_build(x) result(res)
implicit none
@ -242,7 +245,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine z_vect_set_remote_build
subroutine psb_z_set_vect_default(v)
implicit none
class(psb_z_base_vect_type), intent(in) :: v
@ -403,7 +406,7 @@ contains
call psb_erractionsave(err_act)
info = psb_err_alloc_dealloc_
if( allocated(y%v) ) &
if( allocated(y%v) ) &
& call y%v%copy_to_real(x%v,info)
return
@ -415,7 +418,7 @@ contains
class(psb_d_vect_type), intent(inout) :: x
class(psb_z_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
character(len=20) :: name='vec_to_real'
@ -423,11 +426,11 @@ contains
call psb_erractionsave(err_act)
info = psb_err_alloc_dealloc_
if( allocated(y%v) ) &
if( allocated(y%v) ) &
& call y%v%copy_from_real(x%v,info)
return
end subroutine z_vect_copy_from_real
@ -641,7 +644,7 @@ contains
allocate(tmp,stat=info,mold=psb_z_get_base_vect_default())
end if
if (allocated(x%v)) then
if (allocated(x%v%v)) then
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
@ -1105,6 +1108,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
@ -1198,7 +1229,7 @@ contains
! Temp vectors
type(psb_z_vect_type) :: wtemp
info = 0
info = 0
if( allocated(w%v) ) then
if (.not.present(aux)) then
allocate(wtemp%v, mold=w%v)
@ -1390,7 +1421,7 @@ module psb_z_multivect_mod
contains
function z_mvect_get_dupl(x) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: x
@ -1409,7 +1440,7 @@ contains
x%dupl = psb_dupl_def_
end if
end subroutine z_mvect_set_dupl
function z_mvect_is_remote_build(x) result(res)
implicit none
@ -1429,7 +1460,7 @@ contains
x%remote_build = psb_matbld_remote_
end if
end subroutine z_mvect_set_remote_build
subroutine psb_z_set_multivect_default(v)
implicit none

86
base/psblas/psb_caxpby.f90
Unescape Escape View File

@ -741,3 +741,89 @@ 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
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: 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)
ctxt=desc_a%get_context()
call psb_info(ctxt, 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(ctxt,err_act)
return
end subroutine psb_cscal_vect

86
base/psblas/psb_daxpby.f90
Unescape Escape View File

@ -741,3 +741,89 @@ 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
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: 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)
ctxt=desc_a%get_context()
call psb_info(ctxt, 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(ctxt,err_act)
return
end subroutine psb_dscal_vect

86
base/psblas/psb_saxpby.f90
Unescape Escape View File

@ -741,3 +741,89 @@ 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
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: 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)
ctxt=desc_a%get_context()
call psb_info(ctxt, 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(ctxt,err_act)
return
end subroutine psb_sscal_vect

86
base/psblas/psb_zaxpby.f90
Unescape Escape View File

@ -741,3 +741,89 @@ 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
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: 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)
ctxt=desc_a%get_context()
call psb_info(ctxt, 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(ctxt,err_act)
return
end subroutine psb_zscal_vect

36
cbind/base/psb_c_psblas_cbind_mod.f90
Unescape Escape View File

@ -569,6 +569,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

36
cbind/base/psb_d_psblas_cbind_mod.f90
Unescape Escape View File

@ -569,6 +569,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

36
cbind/base/psb_s_psblas_cbind_mod.f90
Unescape Escape View File

@ -569,6 +569,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

36
cbind/base/psb_z_psblas_cbind_mod.f90
Unescape Escape View File

@ -569,6 +569,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

4
krylov/psb_ckrylovsubspace_mod.F90
Unescape Escape View File

@ -254,8 +254,8 @@ contains
goto 9999
end if
scal = cone/kryl%h(i1,i)
! call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
call psb_geaxpby(scal,kryl%v(i1),czero,kryl%v(i1),desc_a,info)
call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
!call psb_geaxpby(scal,kryl%v(i1),czero,kryl%v(i1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

4
krylov/psb_dkrylovsubspace_mod.F90
Unescape Escape View File

@ -254,8 +254,8 @@ contains
goto 9999
end if
scal = done/kryl%h(i1,i)
! call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
call psb_geaxpby(scal,kryl%v(i1),dzero,kryl%v(i1),desc_a,info)
call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
!call psb_geaxpby(scal,kryl%v(i1),dzero,kryl%v(i1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

4
krylov/psb_skrylovsubspace_mod.F90
Unescape Escape View File

@ -254,8 +254,8 @@ contains
goto 9999
end if
scal = sone/kryl%h(i1,i)
! call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
call psb_geaxpby(scal,kryl%v(i1),szero,kryl%v(i1),desc_a,info)
call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
!call psb_geaxpby(scal,kryl%v(i1),szero,kryl%v(i1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

4
krylov/psb_zkrylovsubspace_mod.F90
Unescape Escape View File

@ -254,8 +254,8 @@ contains
goto 9999
end if
scal = zone/kryl%h(i1,i)
! call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
call psb_geaxpby(scal,kryl%v(i1),zzero,kryl%v(i1),desc_a,info)
call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info)
!call psb_geaxpby(scal,kryl%v(i1),zzero,kryl%v(i1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

Write Preview
Loading…
Cancel
Save