From eaaa701c2edb3f0aae929101ebed6500a7ba996e Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 20 Apr 2018 15:13:36 +0100 Subject: [PATCH] New interface for methods with global reductions. --- base/modules/psblas/psb_c_psblas_mod.F90 | 115 ++++++++++++++--------- base/modules/psblas/psb_d_psblas_mod.F90 | 115 ++++++++++++++--------- base/modules/psblas/psb_s_psblas_mod.F90 | 115 ++++++++++++++--------- base/modules/psblas/psb_z_psblas_mod.F90 | 115 ++++++++++++++--------- base/psblas/psb_camax.f90 | 61 +++++++++--- base/psblas/psb_casum.f90 | 58 ++++++++++-- base/psblas/psb_cdot.f90 | 72 +++++++++++--- base/psblas/psb_cnrm2.f90 | 72 +++++++++----- base/psblas/psb_cnrmi.f90 | 12 ++- base/psblas/psb_cspnrm1.f90 | 12 ++- base/psblas/psb_damax.f90 | 61 +++++++++--- base/psblas/psb_dasum.f90 | 58 ++++++++++-- base/psblas/psb_ddot.f90 | 72 +++++++++++--- base/psblas/psb_dnrm2.f90 | 72 +++++++++----- base/psblas/psb_dnrmi.f90 | 12 ++- base/psblas/psb_dspnrm1.f90 | 12 ++- base/psblas/psb_samax.f90 | 61 +++++++++--- base/psblas/psb_sasum.f90 | 58 ++++++++++-- base/psblas/psb_sdot.f90 | 72 +++++++++++--- base/psblas/psb_snrm2.f90 | 72 +++++++++----- base/psblas/psb_snrmi.f90 | 12 ++- base/psblas/psb_sspnrm1.f90 | 12 ++- base/psblas/psb_zamax.f90 | 61 +++++++++--- base/psblas/psb_zasum.f90 | 58 ++++++++++-- base/psblas/psb_zdot.f90 | 72 +++++++++++--- base/psblas/psb_znrm2.f90 | 72 +++++++++----- base/psblas/psb_znrmi.f90 | 12 ++- base/psblas/psb_zspnrm1.f90 | 12 ++- 28 files changed, 1172 insertions(+), 436 deletions(-) diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index 22a1d82e..53271ea9 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -35,50 +35,55 @@ module psb_c_psblas_mod use psb_c_mat_mod, only : psb_cspmat_type interface psb_gedot - function psb_cdot_vect(x, y, desc_a,info) result(res) + function psb_cdot_vect(x, y, desc_a,info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type complex(psb_spk_) :: res type(psb_c_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cdot_vect - function psb_cdotv(x, y, desc_a,info) + function psb_cdotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type complex(psb_spk_) :: psb_cdotv complex(psb_spk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cdotv - function psb_cdot(x, y, desc_a, info, jx, jy) + function psb_cdot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type complex(psb_spk_) :: psb_cdot complex(psb_spk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), optional, intent(in) :: jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cdot end interface interface psb_gedots - subroutine psb_cdotvs(res,x, y, desc_a, info) + subroutine psb_cdotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type complex(psb_spk_), intent(out) :: res complex(psb_spk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_cdotvs - subroutine psb_cmdots(res,x, y, desc_a,info) + subroutine psb_cmdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type complex(psb_spk_), intent(out) :: res(:) complex(psb_spk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_cmdots end interface @@ -91,7 +96,7 @@ module psb_c_psblas_mod type(psb_c_vect_type), intent (inout) :: y complex(psb_spk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_caxpby_vect subroutine psb_caxpbyv(alpha, x, beta, y,& & desc_a, info) @@ -112,35 +117,38 @@ module psb_c_psblas_mod complex(psb_spk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent(in) :: n, jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_caxpby end interface interface psb_geamax - function psb_camax(x, desc_a, info, jx) + function psb_camax(x, desc_a, info, jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) psb_camax complex(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_camax - function psb_camaxv(x, desc_a,info) + function psb_camaxv(x, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) psb_camaxv complex(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_camaxv - function psb_camax_vect(x, desc_a, info) result(res) + function psb_camax_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) :: res type(psb_c_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_camax_vect end interface @@ -154,69 +162,76 @@ module psb_c_psblas_mod #endif interface psb_geamaxs - subroutine psb_camaxvs(res,x,desc_a,info) + subroutine psb_camaxvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_), intent (out) :: res complex(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_camaxvs - subroutine psb_cmamaxs(res,x,desc_a,info,jx) + subroutine psb_cmamaxs(res,x,desc_a,info,jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_), intent (out) :: res(:) complex(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx + logical, intent(in), optional :: global end subroutine psb_cmamaxs end interface interface psb_geasum - function psb_casum_vect(x, desc_a, info) result(res) + function psb_casum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) :: res type(psb_c_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_casum_vect - function psb_casum(x, desc_a, info, jx) + function psb_casum(x, desc_a, info, jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) psb_casum complex(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_casum - function psb_casumv(x, desc_a, info) + function psb_casumv(x, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) psb_casumv complex(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_casumv end interface interface psb_geasums - subroutine psb_casumvs(res,x,desc_a,info) + subroutine psb_casumvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_), intent (out) :: res complex(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_casumvs - subroutine psb_cmasum(res,x,desc_a,info) + subroutine psb_cmasum(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_), intent (out) :: res(:) complex(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_cmasum end interface @@ -230,30 +245,33 @@ module psb_c_psblas_mod #endif interface psb_genrm2 - function psb_cnrm2(x, desc_a, info, jx) + function psb_cnrm2(x, desc_a, info, jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) psb_cnrm2 complex(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cnrm2 - function psb_cnrm2v(x, desc_a, info) + function psb_cnrm2v(x, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) psb_cnrm2v complex(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cnrm2v - function psb_cnrm2_vect(x, desc_a, info) result(res) + function psb_cnrm2_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) :: res type(psb_c_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cnrm2_vect end interface @@ -264,25 +282,27 @@ module psb_c_psblas_mod #endif interface psb_genrm2s - subroutine psb_cnrm2vs(res,x,desc_a,info) + subroutine psb_cnrm2vs(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_), intent (out) :: res complex(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_cnrm2vs end interface interface psb_spnrmi - function psb_cnrmi(a, desc_a,info) + function psb_cnrmi(a, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type real(psb_spk_) :: psb_cnrmi type(psb_cspmat_type), intent (in) :: a type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cnrmi end interface @@ -293,13 +313,14 @@ module psb_c_psblas_mod #endif interface psb_spnrm1 - function psb_cspnrm1(a, desc_a,info) + function psb_cspnrm1(a, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type - real(psb_spk_) :: psb_cspnrm1 + real(psb_spk_) :: psb_cspnrm1 type(psb_cspmat_type), intent (in) :: a - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_cspnrm1 end interface diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index ece28141..56386f92 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -35,50 +35,55 @@ module psb_d_psblas_mod use psb_d_mat_mod, only : psb_dspmat_type interface psb_gedot - function psb_ddot_vect(x, y, desc_a,info) result(res) + function psb_ddot_vect(x, y, desc_a,info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: res type(psb_d_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_ddot_vect - function psb_ddotv(x, y, desc_a,info) + function psb_ddotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: psb_ddotv real(psb_dpk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_ddotv - function psb_ddot(x, y, desc_a, info, jx, jy) + function psb_ddot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: psb_ddot real(psb_dpk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), optional, intent(in) :: jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_ddot end interface interface psb_gedots - subroutine psb_ddotvs(res,x, y, desc_a, info) + subroutine psb_ddotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent(out) :: res real(psb_dpk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_ddotvs - subroutine psb_dmdots(res,x, y, desc_a,info) + subroutine psb_dmdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent(out) :: res(:) real(psb_dpk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_dmdots end interface @@ -91,7 +96,7 @@ module psb_d_psblas_mod type(psb_d_vect_type), intent (inout) :: y real(psb_dpk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_daxpby_vect subroutine psb_daxpbyv(alpha, x, beta, y,& & desc_a, info) @@ -112,35 +117,38 @@ module psb_d_psblas_mod real(psb_dpk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent(in) :: n, jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_daxpby end interface interface psb_geamax - function psb_damax(x, desc_a, info, jx) + function psb_damax(x, desc_a, info, jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) psb_damax real(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_damax - function psb_damaxv(x, desc_a,info) + function psb_damaxv(x, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) psb_damaxv real(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_damaxv - function psb_damax_vect(x, desc_a, info) result(res) + function psb_damax_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: res type(psb_d_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_damax_vect end interface @@ -154,69 +162,76 @@ module psb_d_psblas_mod #endif interface psb_geamaxs - subroutine psb_damaxvs(res,x,desc_a,info) + subroutine psb_damaxvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent (out) :: res real(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_damaxvs - subroutine psb_dmamaxs(res,x,desc_a,info,jx) + subroutine psb_dmamaxs(res,x,desc_a,info,jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent (out) :: res(:) real(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx + logical, intent(in), optional :: global end subroutine psb_dmamaxs end interface interface psb_geasum - function psb_dasum_vect(x, desc_a, info) result(res) + function psb_dasum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: res type(psb_d_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dasum_vect - function psb_dasum(x, desc_a, info, jx) + function psb_dasum(x, desc_a, info, jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) psb_dasum real(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dasum - function psb_dasumv(x, desc_a, info) + function psb_dasumv(x, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) psb_dasumv real(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dasumv end interface interface psb_geasums - subroutine psb_dasumvs(res,x,desc_a,info) + subroutine psb_dasumvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent (out) :: res real(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_dasumvs - subroutine psb_dmasum(res,x,desc_a,info) + subroutine psb_dmasum(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent (out) :: res(:) real(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_dmasum end interface @@ -230,30 +245,33 @@ module psb_d_psblas_mod #endif interface psb_genrm2 - function psb_dnrm2(x, desc_a, info, jx) + function psb_dnrm2(x, desc_a, info, jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) psb_dnrm2 real(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dnrm2 - function psb_dnrm2v(x, desc_a, info) + function psb_dnrm2v(x, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) psb_dnrm2v real(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dnrm2v - function psb_dnrm2_vect(x, desc_a, info) result(res) + function psb_dnrm2_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: res type(psb_d_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dnrm2_vect end interface @@ -264,25 +282,27 @@ module psb_d_psblas_mod #endif interface psb_genrm2s - subroutine psb_dnrm2vs(res,x,desc_a,info) + subroutine psb_dnrm2vs(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent (out) :: res real(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_dnrm2vs end interface interface psb_spnrmi - function psb_dnrmi(a, desc_a,info) + function psb_dnrmi(a, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: psb_dnrmi type(psb_dspmat_type), intent (in) :: a type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dnrmi end interface @@ -293,13 +313,14 @@ module psb_d_psblas_mod #endif interface psb_spnrm1 - function psb_dspnrm1(a, desc_a,info) + function psb_dspnrm1(a, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type - real(psb_dpk_) :: psb_dspnrm1 + real(psb_dpk_) :: psb_dspnrm1 type(psb_dspmat_type), intent (in) :: a - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_dspnrm1 end interface diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index fae7aaf0..a764bb40 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -35,50 +35,55 @@ module psb_s_psblas_mod use psb_s_mat_mod, only : psb_sspmat_type interface psb_gedot - function psb_sdot_vect(x, y, desc_a,info) result(res) + function psb_sdot_vect(x, y, desc_a,info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: res type(psb_s_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_sdot_vect - function psb_sdotv(x, y, desc_a,info) + function psb_sdotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: psb_sdotv real(psb_spk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_sdotv - function psb_sdot(x, y, desc_a, info, jx, jy) + function psb_sdot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: psb_sdot real(psb_spk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), optional, intent(in) :: jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_sdot end interface interface psb_gedots - subroutine psb_sdotvs(res,x, y, desc_a, info) + subroutine psb_sdotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent(out) :: res real(psb_spk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_sdotvs - subroutine psb_smdots(res,x, y, desc_a,info) + subroutine psb_smdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent(out) :: res(:) real(psb_spk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_smdots end interface @@ -91,7 +96,7 @@ module psb_s_psblas_mod type(psb_s_vect_type), intent (inout) :: y real(psb_spk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_saxpby_vect subroutine psb_saxpbyv(alpha, x, beta, y,& & desc_a, info) @@ -112,35 +117,38 @@ module psb_s_psblas_mod real(psb_spk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent(in) :: n, jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_saxpby end interface interface psb_geamax - function psb_samax(x, desc_a, info, jx) + function psb_samax(x, desc_a, info, jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) psb_samax real(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_samax - function psb_samaxv(x, desc_a,info) + function psb_samaxv(x, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) psb_samaxv real(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_samaxv - function psb_samax_vect(x, desc_a, info) result(res) + function psb_samax_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: res type(psb_s_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_samax_vect end interface @@ -154,69 +162,76 @@ module psb_s_psblas_mod #endif interface psb_geamaxs - subroutine psb_samaxvs(res,x,desc_a,info) + subroutine psb_samaxvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent (out) :: res real(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_samaxvs - subroutine psb_smamaxs(res,x,desc_a,info,jx) + subroutine psb_smamaxs(res,x,desc_a,info,jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent (out) :: res(:) real(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx + logical, intent(in), optional :: global end subroutine psb_smamaxs end interface interface psb_geasum - function psb_sasum_vect(x, desc_a, info) result(res) + function psb_sasum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: res type(psb_s_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_sasum_vect - function psb_sasum(x, desc_a, info, jx) + function psb_sasum(x, desc_a, info, jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) psb_sasum real(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_sasum - function psb_sasumv(x, desc_a, info) + function psb_sasumv(x, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) psb_sasumv real(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_sasumv end interface interface psb_geasums - subroutine psb_sasumvs(res,x,desc_a,info) + subroutine psb_sasumvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent (out) :: res real(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_sasumvs - subroutine psb_smasum(res,x,desc_a,info) + subroutine psb_smasum(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent (out) :: res(:) real(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_smasum end interface @@ -230,30 +245,33 @@ module psb_s_psblas_mod #endif interface psb_genrm2 - function psb_snrm2(x, desc_a, info, jx) + function psb_snrm2(x, desc_a, info, jx,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) psb_snrm2 real(psb_spk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_snrm2 - function psb_snrm2v(x, desc_a, info) + function psb_snrm2v(x, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) psb_snrm2v real(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_snrm2v - function psb_snrm2_vect(x, desc_a, info) result(res) + function psb_snrm2_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: res type(psb_s_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_snrm2_vect end interface @@ -264,25 +282,27 @@ module psb_s_psblas_mod #endif interface psb_genrm2s - subroutine psb_snrm2vs(res,x,desc_a,info) + subroutine psb_snrm2vs(res,x,desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent (out) :: res real(psb_spk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_snrm2vs end interface interface psb_spnrmi - function psb_snrmi(a, desc_a,info) + function psb_snrmi(a, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: psb_snrmi type(psb_sspmat_type), intent (in) :: a type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_snrmi end interface @@ -293,13 +313,14 @@ module psb_s_psblas_mod #endif interface psb_spnrm1 - function psb_sspnrm1(a, desc_a,info) + function psb_sspnrm1(a, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type - real(psb_spk_) :: psb_sspnrm1 + real(psb_spk_) :: psb_sspnrm1 type(psb_sspmat_type), intent (in) :: a - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_sspnrm1 end interface diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index b218ce5b..08ee92a7 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -35,50 +35,55 @@ module psb_z_psblas_mod use psb_z_mat_mod, only : psb_zspmat_type interface psb_gedot - function psb_zdot_vect(x, y, desc_a,info) result(res) + function psb_zdot_vect(x, y, desc_a,info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_) :: res type(psb_z_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zdot_vect - function psb_zdotv(x, y, desc_a,info) + function psb_zdotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_) :: psb_zdotv complex(psb_dpk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zdotv - function psb_zdot(x, y, desc_a, info, jx, jy) + function psb_zdot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_) :: psb_zdot complex(psb_dpk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), optional, intent(in) :: jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zdot end interface interface psb_gedots - subroutine psb_zdotvs(res,x, y, desc_a, info) + subroutine psb_zdotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_), intent(out) :: res complex(psb_dpk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_zdotvs - subroutine psb_zmdots(res,x, y, desc_a,info) + subroutine psb_zmdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_), intent(out) :: res(:) complex(psb_dpk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_zmdots end interface @@ -91,7 +96,7 @@ module psb_z_psblas_mod type(psb_z_vect_type), intent (inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_zaxpby_vect subroutine psb_zaxpbyv(alpha, x, beta, y,& & desc_a, info) @@ -112,35 +117,38 @@ module psb_z_psblas_mod complex(psb_dpk_), intent (in) :: alpha, beta type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent(in) :: n, jx, jy - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_zaxpby end interface interface psb_geamax - function psb_zamax(x, desc_a, info, jx) + function psb_zamax(x, desc_a, info, jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) psb_zamax complex(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zamax - function psb_zamaxv(x, desc_a,info) + function psb_zamaxv(x, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) psb_zamaxv complex(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zamaxv - function psb_zamax_vect(x, desc_a, info) result(res) + function psb_zamax_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) :: res type(psb_z_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zamax_vect end interface @@ -154,69 +162,76 @@ module psb_z_psblas_mod #endif interface psb_geamaxs - subroutine psb_zamaxvs(res,x,desc_a,info) + subroutine psb_zamaxvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_), intent (out) :: res complex(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_zamaxvs - subroutine psb_zmamaxs(res,x,desc_a,info,jx) + subroutine psb_zmamaxs(res,x,desc_a,info,jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_), intent (out) :: res(:) complex(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx + logical, intent(in), optional :: global end subroutine psb_zmamaxs end interface interface psb_geasum - function psb_zasum_vect(x, desc_a, info) result(res) + function psb_zasum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) :: res type(psb_z_vect_type), intent (inout) :: x - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zasum_vect - function psb_zasum(x, desc_a, info, jx) + function psb_zasum(x, desc_a, info, jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) psb_zasum complex(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zasum - function psb_zasumv(x, desc_a, info) + function psb_zasumv(x, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) psb_zasumv complex(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zasumv end interface interface psb_geasums - subroutine psb_zasumvs(res,x,desc_a,info) + subroutine psb_zasumvs(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_), intent (out) :: res complex(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_zasumvs - subroutine psb_zmasum(res,x,desc_a,info) + subroutine psb_zmasum(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_), intent (out) :: res(:) complex(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_zmasum end interface @@ -230,30 +245,33 @@ module psb_z_psblas_mod #endif interface psb_genrm2 - function psb_znrm2(x, desc_a, info, jx) + function psb_znrm2(x, desc_a, info, jx,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) psb_znrm2 complex(psb_dpk_), intent (in) :: x(:,:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), optional, intent (in) :: jx - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_znrm2 - function psb_znrm2v(x, desc_a, info) + function psb_znrm2v(x, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) psb_znrm2v complex(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_znrm2v - function psb_znrm2_vect(x, desc_a, info) result(res) + function psb_znrm2_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) :: res type(psb_z_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_znrm2_vect end interface @@ -264,25 +282,27 @@ module psb_z_psblas_mod #endif interface psb_genrm2s - subroutine psb_znrm2vs(res,x,desc_a,info) + subroutine psb_znrm2vs(res,x,desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_), intent (out) :: res complex(psb_dpk_), intent (in) :: x(:) type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end subroutine psb_znrm2vs end interface interface psb_spnrmi - function psb_znrmi(a, desc_a,info) + function psb_znrmi(a, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type real(psb_dpk_) :: psb_znrmi type(psb_zspmat_type), intent (in) :: a type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_znrmi end interface @@ -293,13 +313,14 @@ module psb_z_psblas_mod #endif interface psb_spnrm1 - function psb_zspnrm1(a, desc_a,info) + function psb_zspnrm1(a, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type - real(psb_dpk_) :: psb_zspnrm1 + real(psb_dpk_) :: psb_zspnrm1 type(psb_zspmat_type), intent (in) :: a - type(psb_desc_type), intent (in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global end function psb_zspnrm1 end interface diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 index fea7798e..f9a11055 100644 --- a/base/psblas/psb_camax.f90 +++ b/base/psblas/psb_camax.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_camax(x,desc_a, info, jx) result(res) +function psb_camax(x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_camax implicit none @@ -54,10 +54,12 @@ function psb_camax(x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_camax' @@ -82,6 +84,12 @@ function psb_camax(x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) @@ -107,7 +115,7 @@ function psb_camax(x,desc_a, info, jx) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -162,7 +170,7 @@ end function psb_camax ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_camaxv (x,desc_a, info) result(res) +function psb_camaxv (x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_camaxv implicit none @@ -171,11 +179,12 @@ function psb_camaxv (x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, ldx - + logical :: global_ character(len=20) :: name, ch_err name='psb_camaxv' @@ -193,6 +202,12 @@ function psb_camaxv (x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -221,7 +236,7 @@ function psb_camaxv (x,desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -232,7 +247,7 @@ function psb_camaxv (x,desc_a, info) result(res) end function psb_camaxv -function psb_camax_vect(x, desc_a, info) result(res) +function psb_camax_vect(x, desc_a, info,global) result(res) use psb_penv_mod use psb_serial_mod use psb_desc_mod @@ -245,10 +260,12 @@ function psb_camax_vect(x, desc_a, info) result(res) type(psb_c_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m + logical :: global_ character(len=20) :: name, ch_err name='psb_camaxv' @@ -271,6 +288,12 @@ function psb_camax_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -297,7 +320,7 @@ function psb_camax_vect(x, desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -355,7 +378,7 @@ end function psb_camax_vect ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_camaxvs(res,x,desc_a, info) +subroutine psb_camaxvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_camaxvs implicit none @@ -364,10 +387,12 @@ subroutine psb_camaxvs(res,x,desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_), intent(out) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_camaxvs' @@ -385,6 +410,12 @@ subroutine psb_camaxvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 ijx=1 @@ -412,7 +443,7 @@ subroutine psb_camaxvs(res,x,desc_a, info) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -466,7 +497,7 @@ end subroutine psb_camaxvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_cmamaxs(res,x,desc_a, info,jx) +subroutine psb_cmamaxs(res,x,desc_a, info,jx,global) use psb_base_mod, psb_protect_name => psb_cmamaxs implicit none @@ -476,10 +507,12 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_spk_), intent(out) :: res(:) + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx, i, k + logical :: global_ character(len=20) :: name, ch_err name='psb_cmamaxs' @@ -503,6 +536,12 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) @@ -529,7 +568,7 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) end if ! compute global max - call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_casum.f90 b/base/psblas/psb_casum.f90 index bd77453f..c9e29461 100644 --- a/base/psblas/psb_casum.f90 +++ b/base/psblas/psb_casum.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_casum (x,desc_a, info, jx) result(res) +function psb_casum (x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_casum implicit none @@ -54,10 +54,12 @@ function psb_casum (x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_casum' @@ -82,6 +84,12 @@ function psb_casum (x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness @@ -114,7 +122,7 @@ function psb_casum (x,desc_a, info, jx) result(res) res = szero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -125,7 +133,7 @@ function psb_casum (x,desc_a, info, jx) result(res) end function psb_casum -function psb_casum_vect(x, desc_a, info) result(res) +function psb_casum_vect(x, desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_casum_vect implicit none @@ -133,10 +141,12 @@ function psb_casum_vect(x, desc_a, info) result(res) type(psb_c_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax + & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + logical :: global_ character(len=20) :: name, ch_err name='psb_casumv' @@ -160,6 +170,11 @@ function psb_casum_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx = 1 @@ -182,12 +197,21 @@ function psb_casum_vect(x, desc_a, info) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%asum(desc_a%get_local_rows()) + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + ! adjust res because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*abs(x%v%v(idx)) + end do + end if else res = szero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -242,7 +266,7 @@ end function psb_casum_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_casumv(x,desc_a, info) result(res) +function psb_casumv(x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_casumv implicit none @@ -251,10 +275,12 @@ function psb_casumv(x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_casumv' @@ -271,6 +297,12 @@ function psb_casumv(x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx=1 @@ -307,7 +339,7 @@ function psb_casumv(x,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -362,7 +394,7 @@ end function psb_casumv ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_casumvs(res,x,desc_a, info) +subroutine psb_casumvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_casumvs implicit none @@ -371,10 +403,12 @@ subroutine psb_casumvs(res,x,desc_a, info) real(psb_spk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_casumvs' @@ -391,6 +425,12 @@ subroutine psb_casumvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -427,7 +467,7 @@ subroutine psb_casumvs(res,x,desc_a, info) end if ! compute global sum - call psb_sum(ictxt,res) + if (global_) call psb_sum(ictxt,res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_cdot.f90 b/base/psblas/psb_cdot.f90 index cf7d5f01..c6d545c6 100644 --- a/base/psblas/psb_cdot.f90 +++ b/base/psblas/psb_cdot.f90 @@ -48,7 +48,7 @@ ! jx - integer(optional). The column offset for sub( X ). ! jy - integer(optional). The column offset for sub( Y ). ! -function psb_cdot_vect(x, y, desc_a,info) result(res) +function psb_cdot_vect(x, y, desc_a,info,global) result(res) use psb_desc_mod use psb_c_base_mat_mod use psb_check_mod @@ -61,10 +61,12 @@ function psb_cdot_vect(x, y, desc_a,info) result(res) type(psb_c_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + logical :: global_ character(len=20) :: name, ch_err name='psb_cdot_vect' @@ -91,6 +93,11 @@ function psb_cdot_vect(x, y, desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione ijx = ione @@ -122,17 +129,21 @@ function psb_cdot_vect(x, y, desc_a,info) result(res) res = x%dot(nr,y) ! FIXME ! adjust dot_local because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) -!!$ end do + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*(x%v%v(idx)*y%v%v(idx)) + end do + end if else res = czero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -143,7 +154,7 @@ function psb_cdot_vect(x, y, desc_a,info) result(res) end function psb_cdot_vect -function psb_cdot(x, y,desc_a, info, jx, jy) result(res) +function psb_cdot(x, y,desc_a, info, jx, jy,global) result(res) use psb_base_mod, psb_protect_name => psb_cdot implicit none @@ -152,12 +163,14 @@ function psb_cdot(x, y,desc_a, info, jx, jy) result(res) integer(psb_ipk_), intent(in), optional :: jx, jy integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & & lldx, lldy complex(psb_spk_) :: cdotc + logical :: global_ character(len=20) :: name, ch_err name='psb_cdot' @@ -193,6 +206,12 @@ function psb_cdot(x, y,desc_a, info, jx, jy) result(res) goto 9999 end if + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() lldx = size(x,1) lldy = size(y,1) @@ -228,7 +247,7 @@ function psb_cdot(x, y,desc_a, info, jx, jy) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -284,7 +303,7 @@ end function psb_cdot ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_cdotv(x, y,desc_a, info) result(res) +function psb_cdotv(x, y,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_cdotv implicit none @@ -292,11 +311,13 @@ function psb_cdotv(x, y,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & & lldx, lldy + logical :: global_ complex(psb_spk_) :: cdotc character(len=20) :: name, ch_err @@ -314,6 +335,12 @@ function psb_cdotv(x, y,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione jx = ione @@ -352,7 +379,7 @@ function psb_cdotv(x, y,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) @@ -409,7 +436,7 @@ end function psb_cdotv ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_cdotvs(res, x, y,desc_a, info) +subroutine psb_cdotvs(res, x, y,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_cdotvs implicit none @@ -417,11 +444,13 @@ subroutine psb_cdotvs(res, x, y,desc_a, info) complex(psb_spk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & & lldx, lldy + logical :: global_ complex(psb_spk_) :: cdotc character(len=20) :: name, ch_err @@ -439,6 +468,12 @@ subroutine psb_cdotvs(res, x, y,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione m = desc_a%get_global_rows() @@ -475,7 +510,7 @@ subroutine psb_cdotvs(res, x, y,desc_a, info) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -532,7 +567,7 @@ end subroutine psb_cdotvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_cmdots(res, x, y, desc_a, info) +subroutine psb_cmdots(res, x, y, desc_a, info,global) use psb_base_mod, psb_protect_name => psb_cmdots implicit none @@ -540,11 +575,13 @@ subroutine psb_cmdots(res, x, y, desc_a, info) complex(psb_spk_), intent(out) :: res(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & & lldx, lldy + logical :: global_ complex(psb_spk_) :: cdotc character(len=20) :: name, ch_err @@ -562,6 +599,11 @@ subroutine psb_cmdots(res, x, y, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione iy = ione @@ -611,7 +653,7 @@ subroutine psb_cmdots(res, x, y, desc_a, info) ! compute global sum - call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index 893e3843..f54db995 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset for sub( X ). ! -function psb_cnrm2(x, desc_a, info, jx) result(res) +function psb_cnrm2(x, desc_a, info, jx,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -56,10 +56,12 @@ function psb_cnrm2(x, desc_a, info, jx) result(res) integer(psb_ipk_), intent(in), optional :: jx integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: scnrm2, dd character(len=20) :: name, ch_err @@ -84,6 +86,12 @@ function psb_cnrm2(x, desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) @@ -114,7 +122,7 @@ function psb_cnrm2(x, desc_a, info, jx) result(res) res = szero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -168,7 +176,7 @@ end function psb_cnrm2 ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_cnrm2v(x, desc_a, info) result(res) +function psb_cnrm2v(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -179,13 +187,13 @@ function psb_cnrm2v(x, desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: scnrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_cnrm2v' @@ -202,6 +210,11 @@ function psb_cnrm2v(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 m = desc_a%get_global_rows() @@ -233,8 +246,7 @@ function psb_cnrm2v(x, desc_a, info) result(res) res = szero end if - call psb_nrm2(ictxt,res) - + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -246,7 +258,7 @@ end function psb_cnrm2v -function psb_cnrm2_vect(x, desc_a, info) result(res) +function psb_cnrm2_vect(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -258,12 +270,13 @@ function psb_cnrm2_vect(x, desc_a, info) result(res) type(psb_c_vect_type), intent (inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: snrm2, dd -!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_cnrm2v' @@ -286,6 +299,11 @@ function psb_cnrm2_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 @@ -307,18 +325,21 @@ function psb_cnrm2_vect(x, desc_a, info) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) -!!$ ! adjust because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dd = dble(ndm-1)/dble(ndm) -!!$ nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) -!!$ end do - else + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(cone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else res = szero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -329,7 +350,6 @@ function psb_cnrm2_vect(x, desc_a, info) result(res) end function psb_cnrm2_vect - !!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 @@ -373,7 +393,7 @@ end function psb_cnrm2_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_cnrm2vs(res, x, desc_a, info) +subroutine psb_cnrm2vs(res, x, desc_a, info,global) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -384,13 +404,13 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) real(psb_spk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: nrm2, scnrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_cnrm2' @@ -407,6 +427,12 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 m = desc_a%get_global_rows() @@ -439,7 +465,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) res = szero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 index fced0cbd..9a89a02a 100644 --- a/base/psblas/psb_cnrmi.f90 +++ b/base/psblas/psb_cnrmi.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_cnrmi(a,desc_a,info) result(res) +function psb_cnrmi(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_cnrmi implicit none @@ -49,10 +49,12 @@ function psb_cnrmi(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err name='psb_cnrmi' @@ -69,6 +71,12 @@ function psb_cnrmi(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -101,7 +109,7 @@ function psb_cnrmi(a,desc_a,info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_cspnrm1.f90 b/base/psblas/psb_cspnrm1.f90 index 02a98424..79907295 100644 --- a/base/psblas/psb_cspnrm1.f90 +++ b/base/psblas/psb_cspnrm1.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_cspnrm1(a,desc_a,info) result(res) +function psb_cspnrm1(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_cspnrm1 implicit none @@ -49,10 +49,12 @@ function psb_cspnrm1(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err real(psb_spk_), allocatable :: v(:) @@ -70,6 +72,12 @@ function psb_cspnrm1(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -119,7 +127,7 @@ function psb_cspnrm1(a,desc_a,info) result(res) res = szero end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index b04e9646..4307ba08 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_damax(x,desc_a, info, jx) result(res) +function psb_damax(x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_damax implicit none @@ -54,10 +54,12 @@ function psb_damax(x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_damax' @@ -82,6 +84,12 @@ function psb_damax(x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) @@ -107,7 +115,7 @@ function psb_damax(x,desc_a, info, jx) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -162,7 +170,7 @@ end function psb_damax ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_damaxv (x,desc_a, info) result(res) +function psb_damaxv (x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_damaxv implicit none @@ -171,11 +179,12 @@ function psb_damaxv (x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, ldx - + logical :: global_ character(len=20) :: name, ch_err name='psb_damaxv' @@ -193,6 +202,12 @@ function psb_damaxv (x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -221,7 +236,7 @@ function psb_damaxv (x,desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -232,7 +247,7 @@ function psb_damaxv (x,desc_a, info) result(res) end function psb_damaxv -function psb_damax_vect(x, desc_a, info) result(res) +function psb_damax_vect(x, desc_a, info,global) result(res) use psb_penv_mod use psb_serial_mod use psb_desc_mod @@ -245,10 +260,12 @@ function psb_damax_vect(x, desc_a, info) result(res) type(psb_d_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m + logical :: global_ character(len=20) :: name, ch_err name='psb_damaxv' @@ -271,6 +288,12 @@ function psb_damax_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -297,7 +320,7 @@ function psb_damax_vect(x, desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -355,7 +378,7 @@ end function psb_damax_vect ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_damaxvs(res,x,desc_a, info) +subroutine psb_damaxvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_damaxvs implicit none @@ -364,10 +387,12 @@ subroutine psb_damaxvs(res,x,desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_), intent(out) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_damaxvs' @@ -385,6 +410,12 @@ subroutine psb_damaxvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 ijx=1 @@ -412,7 +443,7 @@ subroutine psb_damaxvs(res,x,desc_a, info) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -466,7 +497,7 @@ end subroutine psb_damaxvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_dmamaxs(res,x,desc_a, info,jx) +subroutine psb_dmamaxs(res,x,desc_a, info,jx,global) use psb_base_mod, psb_protect_name => psb_dmamaxs implicit none @@ -476,10 +507,12 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_dpk_), intent(out) :: res(:) + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx, i, k + logical :: global_ character(len=20) :: name, ch_err name='psb_dmamaxs' @@ -503,6 +536,12 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) @@ -529,7 +568,7 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx) end if ! compute global max - call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index 4871c29f..654df8ef 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_dasum (x,desc_a, info, jx) result(res) +function psb_dasum (x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_dasum implicit none @@ -54,10 +54,12 @@ function psb_dasum (x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_dasum' @@ -82,6 +84,12 @@ function psb_dasum (x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness @@ -114,7 +122,7 @@ function psb_dasum (x,desc_a, info, jx) result(res) res = dzero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -125,7 +133,7 @@ function psb_dasum (x,desc_a, info, jx) result(res) end function psb_dasum -function psb_dasum_vect(x, desc_a, info) result(res) +function psb_dasum_vect(x, desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_dasum_vect implicit none @@ -133,10 +141,12 @@ function psb_dasum_vect(x, desc_a, info) result(res) type(psb_d_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax + & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + logical :: global_ character(len=20) :: name, ch_err name='psb_dasumv' @@ -160,6 +170,11 @@ function psb_dasum_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx = 1 @@ -182,12 +197,21 @@ function psb_dasum_vect(x, desc_a, info) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%asum(desc_a%get_local_rows()) + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + ! adjust res because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*abs(x%v%v(idx)) + end do + end if else res = dzero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -242,7 +266,7 @@ end function psb_dasum_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_dasumv(x,desc_a, info) result(res) +function psb_dasumv(x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_dasumv implicit none @@ -251,10 +275,12 @@ function psb_dasumv(x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_dasumv' @@ -271,6 +297,12 @@ function psb_dasumv(x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx=1 @@ -307,7 +339,7 @@ function psb_dasumv(x,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -362,7 +394,7 @@ end function psb_dasumv ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_dasumvs(res,x,desc_a, info) +subroutine psb_dasumvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_dasumvs implicit none @@ -371,10 +403,12 @@ subroutine psb_dasumvs(res,x,desc_a, info) real(psb_dpk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_dasumvs' @@ -391,6 +425,12 @@ subroutine psb_dasumvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -427,7 +467,7 @@ subroutine psb_dasumvs(res,x,desc_a, info) end if ! compute global sum - call psb_sum(ictxt,res) + if (global_) call psb_sum(ictxt,res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index 2a2b00f3..a679003f 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -48,7 +48,7 @@ ! jx - integer(optional). The column offset for sub( X ). ! jy - integer(optional). The column offset for sub( Y ). ! -function psb_ddot_vect(x, y, desc_a,info) result(res) +function psb_ddot_vect(x, y, desc_a,info,global) result(res) use psb_desc_mod use psb_d_base_mat_mod use psb_check_mod @@ -61,10 +61,12 @@ function psb_ddot_vect(x, y, desc_a,info) result(res) type(psb_d_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + logical :: global_ character(len=20) :: name, ch_err name='psb_ddot_vect' @@ -91,6 +93,11 @@ function psb_ddot_vect(x, y, desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione ijx = ione @@ -122,17 +129,21 @@ function psb_ddot_vect(x, y, desc_a,info) result(res) res = x%dot(nr,y) ! FIXME ! adjust dot_local because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) -!!$ end do + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*(x%v%v(idx)*y%v%v(idx)) + end do + end if else res = dzero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -143,7 +154,7 @@ function psb_ddot_vect(x, y, desc_a,info) result(res) end function psb_ddot_vect -function psb_ddot(x, y,desc_a, info, jx, jy) result(res) +function psb_ddot(x, y,desc_a, info, jx, jy,global) result(res) use psb_base_mod, psb_protect_name => psb_ddot implicit none @@ -152,12 +163,14 @@ function psb_ddot(x, y,desc_a, info, jx, jy) result(res) integer(psb_ipk_), intent(in), optional :: jx, jy integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & & lldx, lldy real(psb_dpk_) :: ddot + logical :: global_ character(len=20) :: name, ch_err name='psb_ddot' @@ -193,6 +206,12 @@ function psb_ddot(x, y,desc_a, info, jx, jy) result(res) goto 9999 end if + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() lldx = size(x,1) lldy = size(y,1) @@ -228,7 +247,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -284,7 +303,7 @@ end function psb_ddot ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_ddotv(x, y,desc_a, info) result(res) +function psb_ddotv(x, y,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_ddotv implicit none @@ -292,11 +311,13 @@ function psb_ddotv(x, y,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & & lldx, lldy + logical :: global_ real(psb_dpk_) :: ddot character(len=20) :: name, ch_err @@ -314,6 +335,12 @@ function psb_ddotv(x, y,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione jx = ione @@ -352,7 +379,7 @@ function psb_ddotv(x, y,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) @@ -409,7 +436,7 @@ end function psb_ddotv ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_ddotvs(res, x, y,desc_a, info) +subroutine psb_ddotvs(res, x, y,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_ddotvs implicit none @@ -417,11 +444,13 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) real(psb_dpk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & & lldx, lldy + logical :: global_ real(psb_dpk_) :: ddot character(len=20) :: name, ch_err @@ -439,6 +468,12 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione m = desc_a%get_global_rows() @@ -475,7 +510,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -532,7 +567,7 @@ end subroutine psb_ddotvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_dmdots(res, x, y, desc_a, info) +subroutine psb_dmdots(res, x, y, desc_a, info,global) use psb_base_mod, psb_protect_name => psb_dmdots implicit none @@ -540,11 +575,13 @@ subroutine psb_dmdots(res, x, y, desc_a, info) real(psb_dpk_), intent(out) :: res(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & & lldx, lldy + logical :: global_ real(psb_dpk_) :: ddot character(len=20) :: name, ch_err @@ -562,6 +599,11 @@ subroutine psb_dmdots(res, x, y, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione iy = ione @@ -611,7 +653,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info) ! compute global sum - call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 14e83d00..66eeca93 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset for sub( X ). ! -function psb_dnrm2(x, desc_a, info, jx) result(res) +function psb_dnrm2(x, desc_a, info, jx,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -56,10 +56,12 @@ function psb_dnrm2(x, desc_a, info, jx) result(res) integer(psb_ipk_), intent(in), optional :: jx integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: dnrm2, dd character(len=20) :: name, ch_err @@ -84,6 +86,12 @@ function psb_dnrm2(x, desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) @@ -114,7 +122,7 @@ function psb_dnrm2(x, desc_a, info, jx) result(res) res = dzero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -168,7 +176,7 @@ end function psb_dnrm2 ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_dnrm2v(x, desc_a, info) result(res) +function psb_dnrm2v(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -179,13 +187,13 @@ function psb_dnrm2v(x, desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: dnrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2v' @@ -202,6 +210,11 @@ function psb_dnrm2v(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 m = desc_a%get_global_rows() @@ -233,8 +246,7 @@ function psb_dnrm2v(x, desc_a, info) result(res) res = dzero end if - call psb_nrm2(ictxt,res) - + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -246,7 +258,7 @@ end function psb_dnrm2v -function psb_dnrm2_vect(x, desc_a, info) result(res) +function psb_dnrm2_vect(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -258,12 +270,13 @@ function psb_dnrm2_vect(x, desc_a, info) result(res) type(psb_d_vect_type), intent (inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: snrm2, dd -!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2v' @@ -286,6 +299,11 @@ function psb_dnrm2_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 @@ -307,18 +325,21 @@ function psb_dnrm2_vect(x, desc_a, info) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) -!!$ ! adjust because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dd = dble(ndm-1)/dble(ndm) -!!$ nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) -!!$ end do - else + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(done - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else res = dzero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -329,7 +350,6 @@ function psb_dnrm2_vect(x, desc_a, info) result(res) end function psb_dnrm2_vect - !!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 @@ -373,7 +393,7 @@ end function psb_dnrm2_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_dnrm2vs(res, x, desc_a, info) +subroutine psb_dnrm2vs(res, x, desc_a, info,global) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -384,13 +404,13 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) real(psb_dpk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: nrm2, dnrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_dnrm2' @@ -407,6 +427,12 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 m = desc_a%get_global_rows() @@ -439,7 +465,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) res = dzero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 1dca687d..9cb0edfe 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_dnrmi(a,desc_a,info) result(res) +function psb_dnrmi(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_dnrmi implicit none @@ -49,10 +49,12 @@ function psb_dnrmi(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err name='psb_dnrmi' @@ -69,6 +71,12 @@ function psb_dnrmi(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -101,7 +109,7 @@ function psb_dnrmi(a,desc_a,info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_dspnrm1.f90 b/base/psblas/psb_dspnrm1.f90 index 9afab5e9..dff6a232 100644 --- a/base/psblas/psb_dspnrm1.f90 +++ b/base/psblas/psb_dspnrm1.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_dspnrm1(a,desc_a,info) result(res) +function psb_dspnrm1(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_dspnrm1 implicit none @@ -49,10 +49,12 @@ function psb_dspnrm1(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err real(psb_dpk_), allocatable :: v(:) @@ -70,6 +72,12 @@ function psb_dspnrm1(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -119,7 +127,7 @@ function psb_dspnrm1(a,desc_a,info) result(res) res = dzero end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 index 456be8c6..a92ceb91 100644 --- a/base/psblas/psb_samax.f90 +++ b/base/psblas/psb_samax.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_samax(x,desc_a, info, jx) result(res) +function psb_samax(x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_samax implicit none @@ -54,10 +54,12 @@ function psb_samax(x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_samax' @@ -82,6 +84,12 @@ function psb_samax(x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) @@ -107,7 +115,7 @@ function psb_samax(x,desc_a, info, jx) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -162,7 +170,7 @@ end function psb_samax ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_samaxv (x,desc_a, info) result(res) +function psb_samaxv (x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_samaxv implicit none @@ -171,11 +179,12 @@ function psb_samaxv (x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, ldx - + logical :: global_ character(len=20) :: name, ch_err name='psb_samaxv' @@ -193,6 +202,12 @@ function psb_samaxv (x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -221,7 +236,7 @@ function psb_samaxv (x,desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -232,7 +247,7 @@ function psb_samaxv (x,desc_a, info) result(res) end function psb_samaxv -function psb_samax_vect(x, desc_a, info) result(res) +function psb_samax_vect(x, desc_a, info,global) result(res) use psb_penv_mod use psb_serial_mod use psb_desc_mod @@ -245,10 +260,12 @@ function psb_samax_vect(x, desc_a, info) result(res) type(psb_s_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m + logical :: global_ character(len=20) :: name, ch_err name='psb_samaxv' @@ -271,6 +288,12 @@ function psb_samax_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -297,7 +320,7 @@ function psb_samax_vect(x, desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -355,7 +378,7 @@ end function psb_samax_vect ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_samaxvs(res,x,desc_a, info) +subroutine psb_samaxvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_samaxvs implicit none @@ -364,10 +387,12 @@ subroutine psb_samaxvs(res,x,desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_), intent(out) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_samaxvs' @@ -385,6 +410,12 @@ subroutine psb_samaxvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 ijx=1 @@ -412,7 +443,7 @@ subroutine psb_samaxvs(res,x,desc_a, info) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -466,7 +497,7 @@ end subroutine psb_samaxvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_smamaxs(res,x,desc_a, info,jx) +subroutine psb_smamaxs(res,x,desc_a, info,jx,global) use psb_base_mod, psb_protect_name => psb_smamaxs implicit none @@ -476,10 +507,12 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_spk_), intent(out) :: res(:) + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx, i, k + logical :: global_ character(len=20) :: name, ch_err name='psb_smamaxs' @@ -503,6 +536,12 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) @@ -529,7 +568,7 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx) end if ! compute global max - call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_sasum.f90 b/base/psblas/psb_sasum.f90 index 10a1b987..e4fe548e 100644 --- a/base/psblas/psb_sasum.f90 +++ b/base/psblas/psb_sasum.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_sasum (x,desc_a, info, jx) result(res) +function psb_sasum (x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_sasum implicit none @@ -54,10 +54,12 @@ function psb_sasum (x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_sasum' @@ -82,6 +84,12 @@ function psb_sasum (x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness @@ -114,7 +122,7 @@ function psb_sasum (x,desc_a, info, jx) result(res) res = szero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -125,7 +133,7 @@ function psb_sasum (x,desc_a, info, jx) result(res) end function psb_sasum -function psb_sasum_vect(x, desc_a, info) result(res) +function psb_sasum_vect(x, desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_sasum_vect implicit none @@ -133,10 +141,12 @@ function psb_sasum_vect(x, desc_a, info) result(res) type(psb_s_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax + & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + logical :: global_ character(len=20) :: name, ch_err name='psb_sasumv' @@ -160,6 +170,11 @@ function psb_sasum_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx = 1 @@ -182,12 +197,21 @@ function psb_sasum_vect(x, desc_a, info) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%asum(desc_a%get_local_rows()) + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + ! adjust res because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*abs(x%v%v(idx)) + end do + end if else res = szero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -242,7 +266,7 @@ end function psb_sasum_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_sasumv(x,desc_a, info) result(res) +function psb_sasumv(x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_sasumv implicit none @@ -251,10 +275,12 @@ function psb_sasumv(x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_sasumv' @@ -271,6 +297,12 @@ function psb_sasumv(x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx=1 @@ -307,7 +339,7 @@ function psb_sasumv(x,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -362,7 +394,7 @@ end function psb_sasumv ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_sasumvs(res,x,desc_a, info) +subroutine psb_sasumvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_sasumvs implicit none @@ -371,10 +403,12 @@ subroutine psb_sasumvs(res,x,desc_a, info) real(psb_spk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_sasumvs' @@ -391,6 +425,12 @@ subroutine psb_sasumvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -427,7 +467,7 @@ subroutine psb_sasumvs(res,x,desc_a, info) end if ! compute global sum - call psb_sum(ictxt,res) + if (global_) call psb_sum(ictxt,res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_sdot.f90 b/base/psblas/psb_sdot.f90 index 86627f07..5afb520d 100644 --- a/base/psblas/psb_sdot.f90 +++ b/base/psblas/psb_sdot.f90 @@ -48,7 +48,7 @@ ! jx - integer(optional). The column offset for sub( X ). ! jy - integer(optional). The column offset for sub( Y ). ! -function psb_sdot_vect(x, y, desc_a,info) result(res) +function psb_sdot_vect(x, y, desc_a,info,global) result(res) use psb_desc_mod use psb_s_base_mat_mod use psb_check_mod @@ -61,10 +61,12 @@ function psb_sdot_vect(x, y, desc_a,info) result(res) type(psb_s_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + logical :: global_ character(len=20) :: name, ch_err name='psb_sdot_vect' @@ -91,6 +93,11 @@ function psb_sdot_vect(x, y, desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione ijx = ione @@ -122,17 +129,21 @@ function psb_sdot_vect(x, y, desc_a,info) result(res) res = x%dot(nr,y) ! FIXME ! adjust dot_local because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) -!!$ end do + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*(x%v%v(idx)*y%v%v(idx)) + end do + end if else res = szero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -143,7 +154,7 @@ function psb_sdot_vect(x, y, desc_a,info) result(res) end function psb_sdot_vect -function psb_sdot(x, y,desc_a, info, jx, jy) result(res) +function psb_sdot(x, y,desc_a, info, jx, jy,global) result(res) use psb_base_mod, psb_protect_name => psb_sdot implicit none @@ -152,12 +163,14 @@ function psb_sdot(x, y,desc_a, info, jx, jy) result(res) integer(psb_ipk_), intent(in), optional :: jx, jy integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & & lldx, lldy real(psb_spk_) :: sdot + logical :: global_ character(len=20) :: name, ch_err name='psb_sdot' @@ -193,6 +206,12 @@ function psb_sdot(x, y,desc_a, info, jx, jy) result(res) goto 9999 end if + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() lldx = size(x,1) lldy = size(y,1) @@ -228,7 +247,7 @@ function psb_sdot(x, y,desc_a, info, jx, jy) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -284,7 +303,7 @@ end function psb_sdot ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_sdotv(x, y,desc_a, info) result(res) +function psb_sdotv(x, y,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_sdotv implicit none @@ -292,11 +311,13 @@ function psb_sdotv(x, y,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & & lldx, lldy + logical :: global_ real(psb_spk_) :: sdot character(len=20) :: name, ch_err @@ -314,6 +335,12 @@ function psb_sdotv(x, y,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione jx = ione @@ -352,7 +379,7 @@ function psb_sdotv(x, y,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) @@ -409,7 +436,7 @@ end function psb_sdotv ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_sdotvs(res, x, y,desc_a, info) +subroutine psb_sdotvs(res, x, y,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_sdotvs implicit none @@ -417,11 +444,13 @@ subroutine psb_sdotvs(res, x, y,desc_a, info) real(psb_spk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & & lldx, lldy + logical :: global_ real(psb_spk_) :: sdot character(len=20) :: name, ch_err @@ -439,6 +468,12 @@ subroutine psb_sdotvs(res, x, y,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione m = desc_a%get_global_rows() @@ -475,7 +510,7 @@ subroutine psb_sdotvs(res, x, y,desc_a, info) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -532,7 +567,7 @@ end subroutine psb_sdotvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_smdots(res, x, y, desc_a, info) +subroutine psb_smdots(res, x, y, desc_a, info,global) use psb_base_mod, psb_protect_name => psb_smdots implicit none @@ -540,11 +575,13 @@ subroutine psb_smdots(res, x, y, desc_a, info) real(psb_spk_), intent(out) :: res(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & & lldx, lldy + logical :: global_ real(psb_spk_) :: sdot character(len=20) :: name, ch_err @@ -562,6 +599,11 @@ subroutine psb_smdots(res, x, y, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione iy = ione @@ -611,7 +653,7 @@ subroutine psb_smdots(res, x, y, desc_a, info) ! compute global sum - call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index f9a35313..f5ef9cb2 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset for sub( X ). ! -function psb_snrm2(x, desc_a, info, jx) result(res) +function psb_snrm2(x, desc_a, info, jx,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -56,10 +56,12 @@ function psb_snrm2(x, desc_a, info, jx) result(res) integer(psb_ipk_), intent(in), optional :: jx integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: snrm2, dd character(len=20) :: name, ch_err @@ -84,6 +86,12 @@ function psb_snrm2(x, desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) @@ -114,7 +122,7 @@ function psb_snrm2(x, desc_a, info, jx) result(res) res = szero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -168,7 +176,7 @@ end function psb_snrm2 ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_snrm2v(x, desc_a, info) result(res) +function psb_snrm2v(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -179,13 +187,13 @@ function psb_snrm2v(x, desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: snrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_snrm2v' @@ -202,6 +210,11 @@ function psb_snrm2v(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 m = desc_a%get_global_rows() @@ -233,8 +246,7 @@ function psb_snrm2v(x, desc_a, info) result(res) res = szero end if - call psb_nrm2(ictxt,res) - + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -246,7 +258,7 @@ end function psb_snrm2v -function psb_snrm2_vect(x, desc_a, info) result(res) +function psb_snrm2_vect(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -258,12 +270,13 @@ function psb_snrm2_vect(x, desc_a, info) result(res) type(psb_s_vect_type), intent (inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: snrm2, dd -!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_snrm2v' @@ -286,6 +299,11 @@ function psb_snrm2_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 @@ -307,18 +325,21 @@ function psb_snrm2_vect(x, desc_a, info) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) -!!$ ! adjust because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dd = dble(ndm-1)/dble(ndm) -!!$ nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) -!!$ end do - else + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else res = szero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -329,7 +350,6 @@ function psb_snrm2_vect(x, desc_a, info) result(res) end function psb_snrm2_vect - !!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 @@ -373,7 +393,7 @@ end function psb_snrm2_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_snrm2vs(res, x, desc_a, info) +subroutine psb_snrm2vs(res, x, desc_a, info,global) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -384,13 +404,13 @@ subroutine psb_snrm2vs(res, x, desc_a, info) real(psb_spk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_spk_) :: nrm2, snrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_snrm2' @@ -407,6 +427,12 @@ subroutine psb_snrm2vs(res, x, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 m = desc_a%get_global_rows() @@ -439,7 +465,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info) res = szero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 index eaeaf127..ecabd400 100644 --- a/base/psblas/psb_snrmi.f90 +++ b/base/psblas/psb_snrmi.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_snrmi(a,desc_a,info) result(res) +function psb_snrmi(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_snrmi implicit none @@ -49,10 +49,12 @@ function psb_snrmi(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err name='psb_snrmi' @@ -69,6 +71,12 @@ function psb_snrmi(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -101,7 +109,7 @@ function psb_snrmi(a,desc_a,info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_sspnrm1.f90 b/base/psblas/psb_sspnrm1.f90 index ea7cd618..b8f2a4b7 100644 --- a/base/psblas/psb_sspnrm1.f90 +++ b/base/psblas/psb_sspnrm1.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_sspnrm1(a,desc_a,info) result(res) +function psb_sspnrm1(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_sspnrm1 implicit none @@ -49,10 +49,12 @@ function psb_sspnrm1(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_spk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err real(psb_spk_), allocatable :: v(:) @@ -70,6 +72,12 @@ function psb_sspnrm1(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -119,7 +127,7 @@ function psb_sspnrm1(a,desc_a,info) result(res) res = szero end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index b2032264..e601725e 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_zamax(x,desc_a, info, jx) result(res) +function psb_zamax(x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_zamax implicit none @@ -54,10 +54,12 @@ function psb_zamax(x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_zamax' @@ -82,6 +84,12 @@ function psb_zamax(x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) @@ -107,7 +115,7 @@ function psb_zamax(x,desc_a, info, jx) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -162,7 +170,7 @@ end function psb_zamax ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_zamaxv (x,desc_a, info) result(res) +function psb_zamaxv (x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_zamaxv implicit none @@ -171,11 +179,12 @@ function psb_zamaxv (x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, ldx - + logical :: global_ character(len=20) :: name, ch_err name='psb_zamaxv' @@ -193,6 +202,12 @@ function psb_zamaxv (x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -221,7 +236,7 @@ function psb_zamaxv (x,desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -232,7 +247,7 @@ function psb_zamaxv (x,desc_a, info) result(res) end function psb_zamaxv -function psb_zamax_vect(x, desc_a, info) result(res) +function psb_zamax_vect(x, desc_a, info,global) result(res) use psb_penv_mod use psb_serial_mod use psb_desc_mod @@ -245,10 +260,12 @@ function psb_zamax_vect(x, desc_a, info) result(res) type(psb_z_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m + logical :: global_ character(len=20) :: name, ch_err name='psb_zamaxv' @@ -271,6 +288,12 @@ function psb_zamax_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -297,7 +320,7 @@ function psb_zamax_vect(x, desc_a, info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -355,7 +378,7 @@ end function psb_zamax_vect ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_zamaxvs(res,x,desc_a, info) +subroutine psb_zamaxvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_zamaxvs implicit none @@ -364,10 +387,12 @@ subroutine psb_zamaxvs(res,x,desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_), intent(out) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_zamaxvs' @@ -385,6 +410,12 @@ subroutine psb_zamaxvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 ijx=1 @@ -412,7 +443,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return @@ -466,7 +497,7 @@ end subroutine psb_zamaxvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_zmamaxs(res,x,desc_a, info,jx) +subroutine psb_zmamaxs(res,x,desc_a, info,jx,global) use psb_base_mod, psb_protect_name => psb_zmamaxs implicit none @@ -476,10 +507,12 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_dpk_), intent(out) :: res(:) + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, ijx, m, ldx, i, k + logical :: global_ character(len=20) :: name, ch_err name='psb_zmamaxs' @@ -503,6 +536,12 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) @@ -529,7 +568,7 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) end if ! compute global max - call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index 3b4fadee..9d49881b 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset. ! -function psb_zasum (x,desc_a, info, jx) result(res) +function psb_zasum (x,desc_a, info, jx,global) result(res) use psb_base_mod, psb_protect_name => psb_zasum implicit none @@ -54,10 +54,12 @@ function psb_zasum (x,desc_a, info, jx) result(res) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: jx real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, & & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_zasum' @@ -82,6 +84,12 @@ function psb_zasum (x,desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness @@ -114,7 +122,7 @@ function psb_zasum (x,desc_a, info, jx) result(res) res = dzero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -125,7 +133,7 @@ function psb_zasum (x,desc_a, info, jx) result(res) end function psb_zasum -function psb_zasum_vect(x, desc_a, info) result(res) +function psb_zasum_vect(x, desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_zasum_vect implicit none @@ -133,10 +141,12 @@ function psb_zasum_vect(x, desc_a, info) result(res) type(psb_z_vect_type), intent (inout) :: x type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax + & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + logical :: global_ character(len=20) :: name, ch_err name='psb_zasumv' @@ -160,6 +170,11 @@ function psb_zasum_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx = 1 @@ -182,12 +197,21 @@ function psb_zasum_vect(x, desc_a, info) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%asum(desc_a%get_local_rows()) + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + ! adjust res because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*abs(x%v%v(idx)) + end do + end if else res = dzero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -242,7 +266,7 @@ end function psb_zasum_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_zasumv(x,desc_a, info) result(res) +function psb_zasumv(x,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_zasumv implicit none @@ -251,10 +275,12 @@ function psb_zasumv(x,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_zasumv' @@ -271,6 +297,12 @@ function psb_zasumv(x,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx=1 @@ -307,7 +339,7 @@ function psb_zasumv(x,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -362,7 +394,7 @@ end function psb_zasumv ! info - integer. Return code ! jx - integer(optional). The column offset. ! -subroutine psb_zasumvs(res,x,desc_a, info) +subroutine psb_zasumvs(res,x,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_zasumvs implicit none @@ -371,10 +403,12 @@ subroutine psb_zasumvs(res,x,desc_a, info) real(psb_dpk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + logical :: global_ character(len=20) :: name, ch_err name='psb_zasumvs' @@ -391,6 +425,12 @@ subroutine psb_zasumvs(res,x,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 @@ -427,7 +467,7 @@ subroutine psb_zasumvs(res,x,desc_a, info) end if ! compute global sum - call psb_sum(ictxt,res) + if (global_) call psb_sum(ictxt,res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index a9cd1d98..9006a08b 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -48,7 +48,7 @@ ! jx - integer(optional). The column offset for sub( X ). ! jy - integer(optional). The column offset for sub( Y ). ! -function psb_zdot_vect(x, y, desc_a,info) result(res) +function psb_zdot_vect(x, y, desc_a,info,global) result(res) use psb_desc_mod use psb_z_base_mat_mod use psb_check_mod @@ -61,10 +61,12 @@ function psb_zdot_vect(x, y, desc_a,info) result(res) type(psb_z_vect_type), intent(inout) :: x, y type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + logical :: global_ character(len=20) :: name, ch_err name='psb_zdot_vect' @@ -91,6 +93,11 @@ function psb_zdot_vect(x, y, desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione ijx = ione @@ -122,17 +129,21 @@ function psb_zdot_vect(x, y, desc_a,info) result(res) res = x%dot(nr,y) ! FIXME ! adjust dot_local because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) -!!$ end do + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + res = res - (real(ndm-1)/real(ndm))*(x%v%v(idx)*y%v%v(idx)) + end do + end if else res = zzero end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -143,7 +154,7 @@ function psb_zdot_vect(x, y, desc_a,info) result(res) end function psb_zdot_vect -function psb_zdot(x, y,desc_a, info, jx, jy) result(res) +function psb_zdot(x, y,desc_a, info, jx, jy,global) result(res) use psb_base_mod, psb_protect_name => psb_zdot implicit none @@ -152,12 +163,14 @@ function psb_zdot(x, y,desc_a, info, jx, jy) result(res) integer(psb_ipk_), intent(in), optional :: jx, jy integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & & lldx, lldy complex(psb_dpk_) :: zdotc + logical :: global_ character(len=20) :: name, ch_err name='psb_zdot' @@ -193,6 +206,12 @@ function psb_zdot(x, y,desc_a, info, jx, jy) result(res) goto 9999 end if + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() lldx = size(x,1) lldy = size(y,1) @@ -228,7 +247,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -284,7 +303,7 @@ end function psb_zdot ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_zdotv(x, y,desc_a, info) result(res) +function psb_zdotv(x, y,desc_a, info,global) result(res) use psb_base_mod, psb_protect_name => psb_zdotv implicit none @@ -292,11 +311,13 @@ function psb_zdotv(x, y,desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & & lldx, lldy + logical :: global_ complex(psb_dpk_) :: zdotc character(len=20) :: name, ch_err @@ -314,6 +335,12 @@ function psb_zdotv(x, y,desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione jx = ione @@ -352,7 +379,7 @@ function psb_zdotv(x, y,desc_a, info) result(res) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) @@ -409,7 +436,7 @@ end function psb_zdotv ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_zdotvs(res, x, y,desc_a, info) +subroutine psb_zdotvs(res, x, y,desc_a, info,global) use psb_base_mod, psb_protect_name => psb_zdotvs implicit none @@ -417,11 +444,13 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) complex(psb_dpk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & & lldx, lldy + logical :: global_ complex(psb_dpk_) :: zdotc character(len=20) :: name, ch_err @@ -439,6 +468,12 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = ione iy = ione m = desc_a%get_global_rows() @@ -475,7 +510,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) end if ! compute global sum - call psb_sum(ictxt, res) + if (global_) call psb_sum(ictxt, res) call psb_erractionrestore(err_act) return @@ -532,7 +567,7 @@ end subroutine psb_zdotvs ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_zmdots(res, x, y, desc_a, info) +subroutine psb_zmdots(res, x, y, desc_a, info,global) use psb_base_mod, psb_protect_name => psb_zmdots implicit none @@ -540,11 +575,13 @@ subroutine psb_zmdots(res, x, y, desc_a, info) complex(psb_dpk_), intent(out) :: res(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & & lldx, lldy + logical :: global_ complex(psb_dpk_) :: zdotc character(len=20) :: name, ch_err @@ -562,6 +599,11 @@ subroutine psb_zmdots(res, x, y, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = ione iy = ione @@ -611,7 +653,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info) ! compute global sum - call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ictxt, res(1:k)) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index 40e2156b..b3fd48df 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -44,7 +44,7 @@ ! info - integer. Return code ! jx - integer(optional). The column offset for sub( X ). ! -function psb_znrm2(x, desc_a, info, jx) result(res) +function psb_znrm2(x, desc_a, info, jx,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -56,10 +56,12 @@ function psb_znrm2(x, desc_a, info, jx) result(res) integer(psb_ipk_), intent(in), optional :: jx integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: dznrm2, dd character(len=20) :: name, ch_err @@ -84,6 +86,12 @@ function psb_znrm2(x, desc_a, info, jx) result(res) ijx = 1 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + m = desc_a%get_global_rows() ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) @@ -114,7 +122,7 @@ function psb_znrm2(x, desc_a, info, jx) result(res) res = dzero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -168,7 +176,7 @@ end function psb_znrm2 ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_znrm2v(x, desc_a, info) result(res) +function psb_znrm2v(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -179,13 +187,13 @@ function psb_znrm2v(x, desc_a, info) result(res) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: dznrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_znrm2v' @@ -202,6 +210,11 @@ function psb_znrm2v(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 m = desc_a%get_global_rows() @@ -233,8 +246,7 @@ function psb_znrm2v(x, desc_a, info) result(res) res = dzero end if - call psb_nrm2(ictxt,res) - + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -246,7 +258,7 @@ end function psb_znrm2v -function psb_znrm2_vect(x, desc_a, info) result(res) +function psb_znrm2_vect(x, desc_a, info,global) result(res) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -258,12 +270,13 @@ function psb_znrm2_vect(x, desc_a, info) result(res) type(psb_z_vect_type), intent (inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: snrm2, dd -!!$ external dcombnrm2 character(len=20) :: name, ch_err name='psb_znrm2v' @@ -286,6 +299,11 @@ function psb_znrm2_vect(x, desc_a, info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if ix = 1 jx=1 @@ -307,18 +325,21 @@ function psb_znrm2_vect(x, desc_a, info) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) -!!$ ! adjust because overlapped elements are computed more than once -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ dd = dble(ndm-1)/dble(ndm) -!!$ nrm2 = nrm2 * sqrt(done - dd*(abs(x(idx))/nrm2)**2) -!!$ end do - else + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(zone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else res = dzero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return @@ -329,7 +350,6 @@ function psb_znrm2_vect(x, desc_a, info) result(res) end function psb_znrm2_vect - !!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 @@ -373,7 +393,7 @@ end function psb_znrm2_vect ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -subroutine psb_znrm2vs(res, x, desc_a, info) +subroutine psb_znrm2vs(res, x, desc_a, info,global) use psb_desc_mod use psb_check_mod use psb_error_mod @@ -384,13 +404,13 @@ subroutine psb_znrm2vs(res, x, desc_a, info) real(psb_dpk_), intent(out) :: res type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + logical :: global_ real(psb_dpk_) :: nrm2, dznrm2, dd - -!!$ external scombnrm2 character(len=20) :: name, ch_err name='psb_znrm2' @@ -407,6 +427,12 @@ subroutine psb_znrm2vs(res, x, desc_a, info) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ix = 1 jx = 1 m = desc_a%get_global_rows() @@ -439,7 +465,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) res = dzero end if - call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index c917b784..c0d169b9 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_znrmi(a,desc_a,info) result(res) +function psb_znrmi(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_znrmi implicit none @@ -49,10 +49,12 @@ function psb_znrmi(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err name='psb_znrmi' @@ -69,6 +71,12 @@ function psb_znrmi(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -101,7 +109,7 @@ function psb_znrmi(a,desc_a,info) result(res) end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return diff --git a/base/psblas/psb_zspnrm1.f90 b/base/psblas/psb_zspnrm1.f90 index 19b5164c..95796ff5 100644 --- a/base/psblas/psb_zspnrm1.f90 +++ b/base/psblas/psb_zspnrm1.f90 @@ -41,7 +41,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! -function psb_zspnrm1(a,desc_a,info) result(res) +function psb_zspnrm1(a,desc_a,info,global) result(res) use psb_base_mod, psb_protect_name => psb_zspnrm1 implicit none @@ -49,10 +49,12 @@ function psb_zspnrm1(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a real(psb_dpk_) :: res + logical, intent(in), optional :: global ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m + logical :: global_ character(len=20) :: name, ch_err real(psb_dpk_), allocatable :: v(:) @@ -70,6 +72,12 @@ function psb_zspnrm1(a,desc_a,info) result(res) goto 9999 endif + if (present(global)) then + global_ = global + else + global_ = .true. + end if + ia = 1 ja = 1 m = desc_a%get_global_rows() @@ -119,7 +127,7 @@ function psb_zspnrm1(a,desc_a,info) result(res) res = dzero end if ! compute global max - call psb_amx(ictxt, res) + if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return