From 8503f02789bf16b0ae4d9d64a97c4284ecfd1af4 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 23 Jun 2010 14:49:55 +0000 Subject: [PATCH] psblas3: base/modules/psb_const_mod.F90 base/modules/psb_d_base_mat_mod.f03 base/modules/psb_d_csc_mat_mod.f03 base/modules/psb_d_csr_mat_mod.f03 base/modules/psb_d_mat_mod.f03 base/modules/psb_d_psblas_mod.f90 base/modules/psb_error_mod.F90 base/psblas/Makefile base/psblas/psb_dnrmi.f90 base/psblas/psb_dspnrm1.f90 base/serial/f03/psb_d_base_mat_impl.f03 base/serial/f03/psb_d_coo_impl.f03 base/serial/f03/psb_d_csc_impl.f03 base/serial/f03/psb_d_csr_impl.f03 base/serial/f03/psb_d_mat_impl.f03 Added ROWSUM,ARWSUM,COLSUM,ACLSUM and SPNRM1. Only for D at this time. --- base/modules/psb_const_mod.F90 | 1 + base/modules/psb_d_base_mat_mod.f03 | 93 +++++++- base/modules/psb_d_csc_mat_mod.f03 | 45 ++++ base/modules/psb_d_csr_mat_mod.f03 | 45 ++++ base/modules/psb_d_mat_mod.f03 | 50 ++++- base/modules/psb_d_psblas_mod.f90 | 11 + base/modules/psb_error_mod.F90 | 3 + base/psblas/Makefile | 1 + base/psblas/psb_dnrmi.f90 | 2 +- base/psblas/psb_dspnrm1.f90 | 143 ++++++++++++ base/serial/f03/psb_d_base_mat_impl.f03 | 134 ++++++++++++ base/serial/f03/psb_d_coo_impl.f03 | 277 ++++++++++++++++++++++-- base/serial/f03/psb_d_csc_impl.f03 | 236 ++++++++++++++++++++ base/serial/f03/psb_d_csr_impl.f03 | 242 +++++++++++++++++++++ base/serial/f03/psb_d_mat_impl.f03 | 181 ++++++++++++++++ 15 files changed, 1445 insertions(+), 19 deletions(-) create mode 100644 base/psblas/psb_dspnrm1.f90 diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index cc8c3814..fd2bb2a9 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -121,6 +121,7 @@ module psb_const_mod integer, parameter, public :: psb_err_iarg_pos_=20 integer, parameter, public :: psb_err_input_value_invalid_i_=30 integer, parameter, public :: psb_err_input_asize_invalid_i_=35 + integer, parameter, public :: psb_err_input_asize_small_i_=36 integer, parameter, public :: psb_err_iarg_invalid_i_=40 integer, parameter, public :: psb_err_iarg_not_gtia_ii_=50 integer, parameter, public :: psb_err_iarg_not_gteia_ii_=60 diff --git a/base/modules/psb_d_base_mat_mod.f03 b/base/modules/psb_d_base_mat_mod.f03 index d1406227..027d9c43 100644 --- a/base/modules/psb_d_base_mat_mod.f03 +++ b/base/modules/psb_d_base_mat_mod.f03 @@ -17,6 +17,11 @@ module psb_d_base_mat_mod procedure, pass(a) :: d_scal => psb_d_base_scal generic, public :: scal => d_scals, d_scal procedure, pass(a) :: csnmi => psb_d_base_csnmi + procedure, pass(a) :: csnm1 => psb_d_base_csnm1 + procedure, pass(a) :: rowsum => psb_d_base_rowsum + procedure, pass(a) :: arwsum => psb_d_base_arwsum + procedure, pass(a) :: colsum => psb_d_base_colsum + procedure, pass(a) :: aclsum => psb_d_base_aclsum procedure, pass(a) :: get_diag => psb_d_base_get_diag procedure, pass(a) :: csput => psb_d_base_csput @@ -66,7 +71,6 @@ module psb_d_base_mat_mod procedure, pass(a) :: d_inner_cssv => psb_d_coo_cssv procedure, pass(a) :: d_scals => psb_d_coo_scals procedure, pass(a) :: d_scal => psb_d_coo_scal - procedure, pass(a) :: csnmi => psb_d_coo_csnmi procedure, pass(a) :: reallocate_nz => psb_d_coo_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_d_coo_allocate_mnnz procedure, pass(a) :: cp_to_coo => psb_d_cp_coo_to_coo @@ -78,6 +82,12 @@ module psb_d_base_mat_mod procedure, pass(a) :: mv_to_fmt => psb_d_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_d_mv_coo_from_fmt procedure, pass(a) :: csput => psb_d_coo_csput + procedure, pass(a) :: csnmi => psb_d_coo_csnmi + procedure, pass(a) :: csnm1 => psb_d_coo_csnm1 + procedure, pass(a) :: rowsum => psb_d_coo_rowsum + procedure, pass(a) :: arwsum => psb_d_coo_arwsum + procedure, pass(a) :: colsum => psb_d_coo_colsum + procedure, pass(a) :: aclsum => psb_d_coo_aclsum procedure, pass(a) :: get_diag => psb_d_coo_get_diag procedure, pass(a) :: d_csgetrow => psb_d_coo_csgetrow procedure, pass(a) :: csgetptn => psb_d_coo_csgetptn @@ -202,6 +212,46 @@ module psb_d_base_mat_mod real(psb_dpk_) :: res end function psb_d_base_csnmi end interface + + interface + function psb_d_base_csnm1(a) result(res) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_base_csnm1 + end interface + + interface + subroutine psb_d_base_rowsum(d,a) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_base_rowsum + end interface + + interface + subroutine psb_d_base_arwsum(d,a) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_base_arwsum + end interface + + interface + subroutine psb_d_base_colsum(d,a) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_base_colsum + end interface + + interface + subroutine psb_d_base_aclsum(d,a) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_base_aclsum + end interface interface subroutine psb_d_base_get_diag(a,d,info) @@ -636,6 +686,47 @@ module psb_d_base_mat_mod end function psb_d_coo_csnmi end interface + interface + function psb_d_coo_csnm1(a) result(res) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_coo_csnm1 + end interface + + interface + subroutine psb_d_coo_rowsum(d,a) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_coo_rowsum + end interface + + interface + subroutine psb_d_coo_arwsum(d,a) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_coo_arwsum + end interface + + interface + subroutine psb_d_coo_colsum(d,a) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_coo_colsum + end interface + + interface + subroutine psb_d_coo_aclsum(d,a) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_coo_aclsum + end interface + + interface subroutine psb_d_coo_get_diag(a,d,info) import psb_d_coo_sparse_mat, psb_dpk_ diff --git a/base/modules/psb_d_csc_mat_mod.f03 b/base/modules/psb_d_csc_mat_mod.f03 index a74fd09c..db2af297 100644 --- a/base/modules/psb_d_csc_mat_mod.f03 +++ b/base/modules/psb_d_csc_mat_mod.f03 @@ -19,6 +19,11 @@ module psb_d_csc_mat_mod procedure, pass(a) :: d_scals => psb_d_csc_scals procedure, pass(a) :: d_scal => psb_d_csc_scal procedure, pass(a) :: csnmi => psb_d_csc_csnmi + procedure, pass(a) :: csnm1 => psb_d_csc_csnm1 + procedure, pass(a) :: rowsum => psb_d_csc_rowsum + procedure, pass(a) :: arwsum => psb_d_csc_arwsum + procedure, pass(a) :: colsum => psb_d_csc_colsum + procedure, pass(a) :: aclsum => psb_d_csc_aclsum procedure, pass(a) :: reallocate_nz => psb_d_csc_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_d_csc_allocate_mnnz procedure, pass(a) :: cp_to_coo => psb_d_cp_csc_to_coo @@ -288,6 +293,46 @@ module psb_d_csc_mat_mod end function psb_d_csc_csnmi end interface + interface + function psb_d_csc_csnm1(a) result(res) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_csc_csnm1 + end interface + + interface + subroutine psb_d_csc_rowsum(d,a) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csc_rowsum + end interface + + interface + subroutine psb_d_csc_arwsum(d,a) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csc_arwsum + end interface + + interface + subroutine psb_d_csc_colsum(d,a) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csc_colsum + end interface + + interface + subroutine psb_d_csc_aclsum(d,a) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csc_aclsum + end interface + interface subroutine psb_d_csc_get_diag(a,d,info) import psb_d_csc_sparse_mat, psb_dpk_ diff --git a/base/modules/psb_d_csr_mat_mod.f03 b/base/modules/psb_d_csr_mat_mod.f03 index ccc4a9c0..965ddcb2 100644 --- a/base/modules/psb_d_csr_mat_mod.f03 +++ b/base/modules/psb_d_csr_mat_mod.f03 @@ -19,6 +19,11 @@ module psb_d_csr_mat_mod procedure, pass(a) :: d_scals => psb_d_csr_scals procedure, pass(a) :: d_scal => psb_d_csr_scal procedure, pass(a) :: csnmi => psb_d_csr_csnmi + procedure, pass(a) :: csnm1 => psb_d_csr_csnm1 + procedure, pass(a) :: rowsum => psb_d_csr_rowsum + procedure, pass(a) :: arwsum => psb_d_csr_arwsum + procedure, pass(a) :: colsum => psb_d_csr_colsum + procedure, pass(a) :: aclsum => psb_d_csr_aclsum procedure, pass(a) :: reallocate_nz => psb_d_csr_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_d_csr_allocate_mnnz procedure, pass(a) :: cp_to_coo => psb_d_cp_csr_to_coo @@ -288,6 +293,46 @@ module psb_d_csr_mat_mod end function psb_d_csr_csnmi end interface + interface + function psb_d_csr_csnm1(a) result(res) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_csr_csnm1 + end interface + + interface + subroutine psb_d_csr_rowsum(d,a) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csr_rowsum + end interface + + interface + subroutine psb_d_csr_arwsum(d,a) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csr_arwsum + end interface + + interface + subroutine psb_d_csr_colsum(d,a) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csr_colsum + end interface + + interface + subroutine psb_d_csr_aclsum(d,a) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_csr_aclsum + end interface + interface subroutine psb_d_csr_get_diag(a,d,info) import psb_d_csr_sparse_mat, psb_dpk_ diff --git a/base/modules/psb_d_mat_mod.f03 b/base/modules/psb_d_mat_mod.f03 index 305b3bfd..b13d50dd 100644 --- a/base/modules/psb_d_mat_mod.f03 +++ b/base/modules/psb_d_mat_mod.f03 @@ -87,6 +87,11 @@ module psb_d_mat_mod ! Computational routines procedure, pass(a) :: get_diag => psb_d_get_diag procedure, pass(a) :: csnmi => psb_d_csnmi + procedure, pass(a) :: csnm1 => psb_d_csnm1 + procedure, pass(a) :: rowsum => psb_d_rowsum + procedure, pass(a) :: arwsum => psb_d_arwsum + procedure, pass(a) :: colsum => psb_d_colsum + procedure, pass(a) :: aclsum => psb_d_aclsum procedure, pass(a) :: d_csmv => psb_d_csmv procedure, pass(a) :: d_csmm => psb_d_csmm generic, public :: csmm => d_csmm, d_csmv @@ -101,8 +106,8 @@ module psb_d_mat_mod private :: psb_d_get_nrows, psb_d_get_ncols, psb_d_get_nzeros, psb_d_get_size, & & psb_d_get_state, psb_d_get_dupl, psb_d_is_null, psb_d_is_bld, psb_d_is_upd, & - & psb_d_is_asb, psb_d_is_sorted, psb_d_is_upper, psb_d_is_lower, psb_d_is_triangle,& - & psb_d_get_nz_row + & psb_d_is_asb, psb_d_is_sorted, psb_d_is_upper, psb_d_is_lower,& + & psb_d_is_triangle, psb_d_get_nz_row interface psb_sizeof module procedure psb_d_sizeof @@ -566,6 +571,47 @@ module psb_d_mat_mod real(psb_dpk_) :: res end function psb_d_csnmi end interface + + interface + function psb_d_csnm1(a) result(res) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_csnm1 + end interface + + interface + subroutine psb_d_rowsum(d,a) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_rowsum + end interface + + interface + subroutine psb_d_arwsum(d,a) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_arwsum + end interface + + interface + subroutine psb_d_colsum(d,a) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_colsum + end interface + + interface + subroutine psb_d_aclsum(d,a) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_d_aclsum + end interface + interface subroutine psb_d_get_diag(a,d,info) diff --git a/base/modules/psb_d_psblas_mod.f90 b/base/modules/psb_d_psblas_mod.f90 index a52a0962..cb11340f 100644 --- a/base/modules/psb_d_psblas_mod.f90 +++ b/base/modules/psb_d_psblas_mod.f90 @@ -201,6 +201,17 @@ module psb_d_psblas_mod end function psb_dnrmi end interface + interface psb_spnrm1 + function psb_dspnrm1(a, desc_a,info) + use psb_descriptor_type, only : psb_desc_type, psb_spk_, psb_dpk_ + use psb_mat_mod, only : psb_d_sparse_mat + real(psb_dpk_) :: psb_dspnrm1 + type(psb_d_sparse_mat), intent (in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_dspnrm1 + end interface + interface psb_spmm subroutine psb_dspmm(alpha, a, x, beta, y, desc_a, info,& &trans, k, jx, jy,work,doswap) diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index a86c5ba7..b87d6144 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -307,6 +307,9 @@ contains case(psb_err_input_asize_invalid_i_) write (error_unit,'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1) write (error_unit,'("Current value is ",i0)')i_e_d(2) + case(psb_err_input_asize_small_i_) + write (error_unit,'("Size of input array argument n. ",i0," is too small.")')i_e_d(1) + write (error_unit,'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3) case(psb_err_iarg_invalid_i_) write (error_unit,'("input argument n. ",i0," has an invalid value")')i_e_d(1) write (error_unit,'("current value is ",a)')a_e_d(2:2) diff --git a/base/psblas/Makefile b/base/psblas/Makefile index 52781ad8..fbb06a8b 100644 --- a/base/psblas/Makefile +++ b/base/psblas/Makefile @@ -3,6 +3,7 @@ include ../../Make.inc #FCOPT=-O2 OBJS= psb_ddot.o psb_damax.o psb_dasum.o psb_daxpby.o\ psb_dnrm2.o psb_dnrmi.o psb_dspmm.o psb_dspsm.o\ + psb_dspnrm1.o \ psb_zamax.o psb_zasum.o psb_zaxpby.o psb_zdot.o \ psb_znrm2.o psb_znrmi.o psb_zspmm.o psb_zspsm.o\ psb_saxpby.o psb_sdot.o psb_sasum.o psb_samax.o\ diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 8018630b..ffae937f 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -34,7 +34,7 @@ ! Function: psb_dnrmi ! Forms the approximated norm of a sparse matrix, ! -! normi := max(abs(sum(A(i,j)))) +! normi := max(sum(abs(A(i,:)))) ! ! Arguments: ! a - type(psb_dspmat_type). The sparse matrix containing A. diff --git a/base/psblas/psb_dspnrm1.f90 b/base/psblas/psb_dspnrm1.f90 new file mode 100644 index 00000000..d881a3d0 --- /dev/null +++ b/base/psblas/psb_dspnrm1.f90 @@ -0,0 +1,143 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_dnrmi.f90 +! +! Function: psb_dnrmi +! Forms the approximated norm of a sparse matrix, +! +! norm1 := max(sum(abs(A(:,j)))) +! +! Arguments: +! a - type(psb_dspmat_type). The sparse matrix containing A. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_dspnrm1(a,desc_a,info) +!!$ use psb_descriptor_type +!!$ use psb_serial_mod +!!$ use psb_check_mod +!!$ use psb_error_mod +!!$ use psb_penv_mod +!!$ use psb_mat_mod +!!$ use psb_tools_mod + use psb_sparse_mod, psb_protect_name => psb_dspnrm1 + implicit none + + type(psb_d_sparse_mat), intent(in) :: a + integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_) :: psb_dspnrm1 + + ! locals + integer :: ictxt, np, me, nr,nc,& + & err_act, n, iia, jja, ia, ja, mdim, ndim, m + real(psb_dpk_) :: nrm1 + character(len=20) :: name, ch_err + real(psb_dpk_), allocatable :: v(:) + + name='psb_dnrm1' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ia = 1 + ja = 1 + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nr = psb_cd_get_local_rows(desc_a) + nc = psb_cd_get_local_cols(desc_a) + + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iia /= 1).or.(jja /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_geall(v,desc_a,info) + if(info == psb_success_) then + v = dzero + call psb_geasb(v,desc_a,info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='geall/asb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((m /= 0).and.(n /= 0)) then + call a%aclsum(v) + call psb_halo(v,desc_a,info,tran='T') + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + nrm1 = maxval(v(1:nr)) + else + nrm1 = 0.d0 + end if + ! compute global max + call psb_amx(ictxt, nrm1) + + psb_dspnrm1 = nrm1 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end function psb_dspnrm1 diff --git a/base/serial/f03/psb_d_base_mat_impl.f03 b/base/serial/f03/psb_d_base_mat_impl.f03 index d57f9f8e..ad5845a6 100644 --- a/base/serial/f03/psb_d_base_mat_impl.f03 +++ b/base/serial/f03/psb_d_base_mat_impl.f03 @@ -1044,6 +1044,140 @@ function psb_d_base_csnmi(a) result(res) end function psb_d_base_csnmi +function psb_d_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csnm1 + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_d_base_csnm1 + +subroutine psb_d_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_rowsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_rowsum + +subroutine psb_d_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_arwsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_arwsum + +subroutine psb_d_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_colsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_colsum + +subroutine psb_d_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_aclsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_aclsum + + subroutine psb_d_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod diff --git a/base/serial/f03/psb_d_coo_impl.f03 b/base/serial/f03/psb_d_coo_impl.f03 index ee78dfa4..e8424fb7 100644 --- a/base/serial/f03/psb_d_coo_impl.f03 +++ b/base/serial/f03/psb_d_coo_impl.f03 @@ -1341,31 +1341,278 @@ function psb_d_coo_csnmi(a) result(res) class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer :: i,j,k,m,n, nnz, ir, jc, nc + integer :: i,j,k,m,n, nnz, ir, jc, nc, info real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) logical :: tra Integer :: err_act - character(len=20) :: name='d_base_csnmi' + character(len=20) :: name='d_coo_csnmi' logical, parameter :: debug=.false. - res = dzero + res = -done nnz = a%get_nzeros() - i = 1 - j = i - do while (i<=nnz) - do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) - j = j+1 - enddo - acc = dzero - do k=i, j-1 - acc = acc + abs(a%val(k)) + if (a%is_sorted()) then + i = 1 + j = i + res = dzero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + acc = dzero + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + vt(:) = dzero + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) end do - res = max(res,acc) - i = j + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_d_coo_csnmi + + +function psb_d_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csnm1 + + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_coo_csnm1' + logical, parameter :: debug=.false. + + + res = -done + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + vt(:) = dzero + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) -end function psb_d_coo_csnmi + return + +end function psb_d_coo_csnm1 + +subroutine psb_d_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_rowsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_rowsum + +subroutine psb_d_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_arwsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_arwsum + +subroutine psb_d_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_colsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_colsum + +subroutine psb_d_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_aclsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_aclsum diff --git a/base/serial/f03/psb_d_csc_impl.f03 b/base/serial/f03/psb_d_csc_impl.f03 index 53176ec9..cbe998ff 100644 --- a/base/serial/f03/psb_d_csc_impl.f03 +++ b/base/serial/f03/psb_d_csc_impl.f03 @@ -1061,6 +1061,242 @@ function psb_d_csc_csnmi(a) result(res) end function psb_d_csc_csnmi +function psb_d_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csnm1 + + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csc_csnm1' + logical, parameter :: debug=.false. + + + res = dzero + m = a%get_nrows() + n = a%get_ncols() + do j=1, n + acc = dzero + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_d_csc_csnm1 + +subroutine psb_d_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_colsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + do i = 1, a%get_ncols() + d(i) = dzero + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_colsum + +subroutine psb_d_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_aclsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + + do i = 1, a%get_ncols() + d(i) = dzero + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_aclsum + +subroutine psb_d_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_rowsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_rowsum + +subroutine psb_d_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_arwsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_arwsum + + subroutine psb_d_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod diff --git a/base/serial/f03/psb_d_csr_impl.f03 b/base/serial/f03/psb_d_csr_impl.f03 index 64c994b9..508680b2 100644 --- a/base/serial/f03/psb_d_csr_impl.f03 +++ b/base/serial/f03/psb_d_csr_impl.f03 @@ -1071,6 +1071,248 @@ function psb_d_csr_csnmi(a) result(res) end function psb_d_csr_csnmi + +function psb_d_csr_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csnm1 + + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csr_csnm1' + logical, parameter :: debug=.false. + + + res = -done + nnz = a%get_nzeros() + m = a%get_nrows() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + vt(:) = dzero + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + vt(k) = vt(k) + abs(a%val(k)) + end do + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_d_csr_csnm1 + +subroutine psb_d_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_rowsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_rowsum + +subroutine psb_d_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_arwsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_arwsum + +subroutine psb_d_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_colsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_colsum + +subroutine psb_d_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_aclsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_aclsum + + subroutine psb_d_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod diff --git a/base/serial/f03/psb_d_mat_impl.f03 b/base/serial/f03/psb_d_mat_impl.f03 index 917b8cba..7d90bcd7 100644 --- a/base/serial/f03/psb_d_mat_impl.f03 +++ b/base/serial/f03/psb_d_mat_impl.f03 @@ -1856,6 +1856,187 @@ function psb_d_csnmi(a) result(res) end function psb_d_csnmi +function psb_d_csnm1(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_d_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnm1() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_d_csnm1 + + +subroutine psb_d_rowsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%rowsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_rowsum + +subroutine psb_d_arwsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%arwsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_arwsum + +subroutine psb_d_colsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%colsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_colsum + +subroutine psb_d_aclsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%aclsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_aclsum + subroutine psb_d_get_diag(a,d,info) use psb_d_mat_mod, psb_protect_name => psb_d_get_diag use psb_error_mod