From c0e676dab77b9aee0d2c5fe9fbe93c0d2a1e312f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 11 Jun 2018 22:13:26 +0100 Subject: [PATCH] Fold LX into X files. --- base/modules/serial/psb_lbase_mat_mod.f90 | 901 ---- base/modules/serial/psb_ld_base_mat_mod.f90 | 1968 --------- base/modules/serial/psb_ld_csc_mat_mod.f90 | 612 --- base/modules/serial/psb_ld_csr_mat_mod.f90 | 617 --- base/modules/serial/psb_ld_mat_mod.F90 | 1379 ------- base/modules/serial/psb_ld_serial_mod.f90 | 233 -- base/serial/impl/psb_c_lbase_mat_impl.F90 | 2320 ----------- base/serial/impl/psb_c_lcoo_impl.f90 | 4127 ------------------- base/serial/impl/psb_d_lbase_mat_impl.F90 | 2320 ----------- base/serial/impl/psb_d_lcoo_impl.f90 | 4127 ------------------- base/serial/impl/psb_s_lbase_mat_impl.F90 | 2320 ----------- base/serial/impl/psb_s_lcoo_impl.f90 | 4127 ------------------- base/serial/impl/psb_z_lbase_mat_impl.F90 | 2320 ----------- base/serial/impl/psb_z_lcoo_impl.f90 | 4127 ------------------- 14 files changed, 31498 deletions(-) delete mode 100644 base/modules/serial/psb_lbase_mat_mod.f90 delete mode 100644 base/modules/serial/psb_ld_base_mat_mod.f90 delete mode 100644 base/modules/serial/psb_ld_csc_mat_mod.f90 delete mode 100644 base/modules/serial/psb_ld_csr_mat_mod.f90 delete mode 100644 base/modules/serial/psb_ld_mat_mod.F90 delete mode 100644 base/modules/serial/psb_ld_serial_mod.f90 delete mode 100644 base/serial/impl/psb_c_lbase_mat_impl.F90 delete mode 100644 base/serial/impl/psb_c_lcoo_impl.f90 delete mode 100644 base/serial/impl/psb_d_lbase_mat_impl.F90 delete mode 100644 base/serial/impl/psb_d_lcoo_impl.f90 delete mode 100644 base/serial/impl/psb_s_lbase_mat_impl.F90 delete mode 100644 base/serial/impl/psb_s_lcoo_impl.f90 delete mode 100644 base/serial/impl/psb_z_lbase_mat_impl.F90 delete mode 100644 base/serial/impl/psb_z_lcoo_impl.f90 diff --git a/base/modules/serial/psb_lbase_mat_mod.f90 b/base/modules/serial/psb_lbase_mat_mod.f90 deleted file mode 100644 index 80007995..00000000 --- a/base/modules/serial/psb_lbase_mat_mod.f90 +++ /dev/null @@ -1,901 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_lbase_mat_mod -! -! This module contains the definition of the very basic object -! psb_lbase_sparse_mat holding some information common to all matrix -! type variants, such as number of rows and columns, whether the -! matrix is supposed to be triangular (upper or lower) and with a unit -! (i.e. assumed) diagonal, together with some state variables. This -! base class is in common among all variants of real/complex, -! short/long precision; as such, it only contains information that is -! inherently integer in nature. -! -! The methods associated to this class can be grouped into three sets: -! 1) Fully implemented methods: some methods such as get_nrows or -! set_nrows can be fully implemented at this level. -! 2) Partially implemented methods: Some methods have an -! implementation that is split between this level and the leaf -! level. For example, the matrix transposition can be partially -! done at this level (swapping of the rows and columns dimensions) -! but it has to be completed by a method defined at the leaf level -! (for actually transposing the row and column indices). -! 3) Other methods: There are a number of methods that are defined -! (i.e their interface is defined) but not implemented at this -! level. This methods will be overwritten at the leaf level with -! an actual implementation. If it is not the case, the method -! defined at this level will raise an error. These methods are -! defined in the serial/f03/psb_lbase_mat_impl.f03 file -! -! - -module psb_lbase_mat_mod - - use psb_const_mod - use psi_serial_mod - - ! - !> \namespace psb_lbase_mod \class psb_lbase_sparse_mat - !! The basic data about your matrix. - !! This class is extended twice, to provide the various - !! data variations S/D/C/Z and to implement the actual - !! storage formats. The grandchild classes are then - !! encapsulated to implement the STATE design pattern. - !! We have an ambiguity in that the inner class has a - !! "state" variable; we hope the context will make it clear. - !! - !! - !! The methods associated to this class can be grouped into three sets: - !! - Fully implemented methods: some methods such as get_nrows or - !! set_nrows can be fully implemented at this level. - !! - Partially implemented methods: Some methods have an - !! implementation that is split between this level and the leaf - !! level. For example, the matrix transposition can be partially - !! done at this level (swapping of the rows and columns dimensions) - !! but it has to be completed by a method defined at the leaf level - !! (for actually transposing the row and column indices). - !! - Other methods: There are a number of methods that are defined - !! (i.e their interface is defined) but not implemented at this - !! level. This methods will be overwritten at the leaf level with - !! an actual implementation. If it is not the case, the method - !! defined at this level will raise an error. These methods are - !! defined in the serial/impl/psb_lbase_mat_impl.f90 file - !! - ! - - type :: psb_lbase_sparse_mat - !> Row size - integer(psb_lpk_), private :: m - !> Col size - integer(psb_lpk_), private :: n - !> Matrix state: - !! null: pristine; - !! build: it's being filled with entries; - !! assembled: ready to use in computations; - !! update: accepts coefficients but only - !! in already existing entries. - !! The transitions among the states are detailed in - !! psb_T_mat_mod. - integer(psb_ipk_), private :: state - !> How to treat duplicate elements when - !! transitioning from the BUILD to the ASSEMBLED state. - !! While many formats would allow for duplicate - !! entries, it is much better to constrain the matrices - !! NOT to have duplicate entries, except while in the - !! BUILD state; in our overall design, only COO matrices - !! can ever be in the BUILD state, hence all other formats - !! cannot have duplicate entries. - integer(psb_ipk_), private :: duplicate - !> Is the matrix triangular? (must also be square) - logical, private :: triangle - !> Is the matrix upper or lower? (only if triangular) - logical, private :: upper - !> Is the matrix diagonal stored or assumed unitary? (only if triangular) - logical, private :: unitd - !> Are the coefficients sorted ? - logical, private :: sorted - logical, private :: repeatable_updates=.false. - - contains - - ! == = ================================= - ! - ! Getters - ! - ! - ! == = ================================= - procedure, pass(a) :: get_nrows => psb_lbase_get_nrows - procedure, pass(a) :: get_ncols => psb_lbase_get_ncols - procedure, pass(a) :: get_nzeros => psb_lbase_get_nzeros - procedure, pass(a) :: get_nz_row => psb_lbase_get_nz_row - procedure, pass(a) :: get_size => psb_lbase_get_size - procedure, pass(a) :: get_state => psb_lbase_get_state - procedure, pass(a) :: get_dupl => psb_lbase_get_dupl - procedure, nopass :: get_fmt => psb_lbase_get_fmt - procedure, nopass :: has_update => psb_lbase_has_update - procedure, pass(a) :: is_null => psb_lbase_is_null - procedure, pass(a) :: is_bld => psb_lbase_is_bld - procedure, pass(a) :: is_upd => psb_lbase_is_upd - procedure, pass(a) :: is_asb => psb_lbase_is_asb - procedure, pass(a) :: is_sorted => psb_lbase_is_sorted - procedure, pass(a) :: is_upper => psb_lbase_is_upper - procedure, pass(a) :: is_lower => psb_lbase_is_lower - procedure, pass(a) :: is_triangle => psb_lbase_is_triangle - procedure, pass(a) :: is_unit => psb_lbase_is_unit - procedure, pass(a) :: is_by_rows => psb_lbase_is_by_rows - procedure, pass(a) :: is_by_cols => psb_lbase_is_by_cols - procedure, pass(a) :: is_repeatable_updates => psb_lbase_is_repeatable_updates - - ! == = ================================= - ! - ! Setters - ! - ! == = ================================= - procedure, pass(a) :: set_nrows => psb_lbase_set_nrows - procedure, pass(a) :: set_ncols => psb_lbase_set_ncols - procedure, pass(a) :: set_dupl => psb_lbase_set_dupl - procedure, pass(a) :: set_state => psb_lbase_set_state - procedure, pass(a) :: set_null => psb_lbase_set_null - procedure, pass(a) :: set_bld => psb_lbase_set_bld - procedure, pass(a) :: set_upd => psb_lbase_set_upd - procedure, pass(a) :: set_asb => psb_lbase_set_asb - procedure, pass(a) :: set_sorted => psb_lbase_set_sorted - procedure, pass(a) :: set_upper => psb_lbase_set_upper - procedure, pass(a) :: set_lower => psb_lbase_set_lower - procedure, pass(a) :: set_triangle => psb_lbase_set_triangle - procedure, pass(a) :: set_unit => psb_lbase_set_unit - - procedure, pass(a) :: set_repeatable_updates => psb_lbase_set_repeatable_updates - - - ! == = ================================= - ! - ! Data management - ! - ! == = ================================= - procedure, pass(a) :: get_neigh => psb_lbase_get_neigh - procedure, pass(a) :: free => psb_lbase_free - procedure, pass(a) :: asb => psb_lbase_mat_asb - procedure, pass(a) :: trim => psb_lbase_trim - procedure, pass(a) :: reinit => psb_lbase_reinit - procedure, pass(a) :: allocate_mnnz => psb_lbase_allocate_mnnz - procedure, pass(a) :: reallocate_nz => psb_lbase_reallocate_nz - generic, public :: allocate => allocate_mnnz - generic, public :: reallocate => reallocate_nz - - - procedure, pass(a) :: csgetptn => psb_lbase_csgetptn - generic, public :: csget => csgetptn - procedure, pass(a) :: print => psb_lbase_sparse_print - procedure, pass(a) :: sizeof => psb_lbase_sizeof - procedure, pass(a) :: transp_1mat => psb_lbase_transp_1mat - procedure, pass(a) :: transp_2mat => psb_lbase_transp_2mat - generic, public :: transp => transp_1mat, transp_2mat - procedure, pass(a) :: transc_1mat => psb_lbase_transc_1mat - procedure, pass(a) :: transc_2mat => psb_lbase_transc_2mat - generic, public :: transc => transc_1mat, transc_2mat - - ! - ! Sync: centerpiece of handling of external storage. - ! Any derived class having extra storage upon sync - ! will guarantee that both fortran/host side and - ! external side contain the same data. The base - ! version is only a placeholder. - ! - procedure, pass(a) :: sync => psb_lbase_mat_sync - procedure, pass(a) :: is_host => psb_lbase_mat_is_host - procedure, pass(a) :: is_dev => psb_lbase_mat_is_dev - procedure, pass(a) :: is_sync => psb_lbase_mat_is_sync - procedure, pass(a) :: set_host => psb_lbase_mat_set_host - procedure, pass(a) :: set_dev => psb_lbase_mat_set_dev - procedure, pass(a) :: set_sync => psb_lbase_mat_set_sync - - end type psb_lbase_sparse_mat - - !> Function: psb_lbase_get_nz_row - !! \memberof psb_lbase_sparse_mat - !! Interface for the get_nz_row method. Equivalent to: - !! count(A(idx,:)/=0) - !! \param idx The line we are interested in. - ! - interface - function psb_lbase_get_nz_row(idx,a) result(res) - import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat - integer(psb_lpk_), intent(in) :: idx - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - end function psb_lbase_get_nz_row - end interface - - ! - !> Function: psb_lbase_get_nzeros - !! \memberof psb_lbase_sparse_mat - !! Interface for the get_nzeros method. Equivalent to: - !! count(A(:,:)/=0) - ! - interface - function psb_lbase_get_nzeros(a) result(res) - import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - end function psb_lbase_get_nzeros - end interface - - !> Function get_size - !! \memberof psb_lbase_sparse_mat - !! how many items can A hold with - !! its current space allocation? - !! (as opposed to how many are - !! currently occupied) - ! - interface - function psb_lbase_get_size(a) result(res) - import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - end function psb_lbase_get_size - end interface - - ! - !> Function reinit: transition state from ASB to UPDATE - !! \memberof psb_lbase_sparse_mat - !! \param clear [true] explicitly zero out coefficients. - ! - interface - subroutine psb_lbase_reinit(a,clear) - import :: psb_ipk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_lbase_reinit - end interface - - - ! - !> Function - !! \memberof psb_lbase_sparse_mat - !! print on file in Matrix Market format. - !! \param iout the output unit - !! \param iv(:) [none] renumber both row and column indices - !! \param head [none] a descriptive header for the matrix data - !! \param ivr(:) [none] renumbering for the rows - !! \param ivc(:) [none] renumbering for the cols - ! - interface - subroutine psb_lbase_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - integer(psb_ipk_), intent(in) :: iout - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_lbase_sparse_print - end interface - - - ! - !> Function getptn: - !! \memberof psb_lbase_sparse_mat - !! \brief Get the pattern. - !! - !! - !! Return a list of NZ pairs - !! (IA(i),JA(i)) - !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; - !! IA,JA are reallocated as necessary. - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in - !! \param nz the number of output coefficients - !! \param ia(:) the output row indices - !! \param ja(:) the output col indices - !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index - !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) - !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] - !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] - !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja - !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - ! - - interface - subroutine psb_lbase_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_lbase_csgetptn - end interface - - ! - !> Function get_neigh: - !! \memberof psb_lbase_sparse_mat - !! \brief Get the neighbours. - !! - !! - !! Return a list of N indices of neighbours of index idx, - !! i.e. the indices of the nonzeros in row idx of matrix A - !! \param idx the index we are interested in - !! \param neigh(:) the list of indices, reallocated as necessary - !! \param n the number of indices returned - !! \param info return code - !! \param lev [1] find neighbours recursively for LEV levels, - !! i.e. when lev=2 find neighours of neighbours, etc. - ! - interface - subroutine psb_lbase_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n - integer(psb_lpk_), allocatable, intent(out) :: neigh(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev - end subroutine psb_lbase_get_neigh - end interface - - ! - ! - !> Function allocate_mnnz - !! \memberof psb_lbase_sparse_mat - !! \brief Three-parameters version of allocate - !! - !! \param m number of rows - !! \param n number of cols - !! \param nz [estimated internally] number of nonzeros to allocate for - ! - interface - subroutine psb_lbase_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - integer(psb_lpk_), intent(in) :: m,n - class(psb_lbase_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_lbase_allocate_mnnz - end interface - - - ! - ! - !> Function reallocate_nz - !! \memberof psb_lbase_sparse_mat - !! \brief One--parameter version of (re)allocate - !! - !! \param nz number of nonzeros to allocate for - ! - interface - subroutine psb_lbase_reallocate_nz(nz,a) - import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - integer(psb_lpk_), intent(in) :: nz - class(psb_lbase_sparse_mat), intent(inout) :: a - end subroutine psb_lbase_reallocate_nz - end interface - - ! - !> Function free - !! \memberof psb_lbase_sparse_mat - !! \brief destructor - ! - interface - subroutine psb_lbase_free(a) - import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(inout) :: a - end subroutine psb_lbase_free - end interface - - ! - !> Function trim - !! \memberof psb_lbase_sparse_mat - !! \brief Memory trim - !! Make sure the memory allocation of the sparse matrix is as tight as - !! possible given the actual number of nonzeros it contains. - ! - interface - subroutine psb_lbase_trim(a) - import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(inout) :: a - end subroutine psb_lbase_trim - end interface - - -contains - - - ! - !> Function sizeof - !! \memberof psb_lbase_sparse_mat - !! \brief Memory occupation in byes - ! - function psb_lbase_sizeof(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_epk_) :: res - res = 8 - end function psb_lbase_sizeof - - ! - !> Function get_fmt - !! \memberof psb_lbase_sparse_mat - !! \brief return a short descriptive name (e.g. COO CSR etc.) - ! - function psb_lbase_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'NULL' - end function psb_lbase_get_fmt - ! - !> Function has_update - !! \memberof psb_lbase_sparse_mat - !! \brief Does the forma have the UPDATE functionality? - ! - function psb_lbase_has_update() result(res) - implicit none - logical :: res - res = .true. - end function psb_lbase_has_update - - ! - ! Standard getter functions: self-explaining. - ! - function psb_lbase_get_dupl(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_ipk_) :: res - res = a%duplicate - end function psb_lbase_get_dupl - - - function psb_lbase_get_state(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_ipk_) :: res - res = a%state - end function psb_lbase_get_state - - function psb_lbase_get_nrows(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - res = a%m - end function psb_lbase_get_nrows - - function psb_lbase_get_ncols(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - res = a%n - end function psb_lbase_get_ncols - - subroutine psb_lbase_set_nrows(m,a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in) :: m - a%m = m - end subroutine psb_lbase_set_nrows - - subroutine psb_lbase_set_ncols(n,a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in) :: n - a%n = n - end subroutine psb_lbase_set_ncols - - - subroutine psb_lbase_set_state(n,a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in) :: n - a%state = n - end subroutine psb_lbase_set_state - - - subroutine psb_lbase_set_dupl(n,a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - a%duplicate = n - end subroutine psb_lbase_set_dupl - - subroutine psb_lbase_set_null(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - a%state = psb_spmat_null_ - end subroutine psb_lbase_set_null - - subroutine psb_lbase_set_bld(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - a%state = psb_spmat_bld_ - end subroutine psb_lbase_set_bld - - subroutine psb_lbase_set_upd(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - a%state = psb_spmat_upd_ - end subroutine psb_lbase_set_upd - - subroutine psb_lbase_set_asb(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - a%state = psb_spmat_asb_ - end subroutine psb_lbase_set_asb - - subroutine psb_lbase_set_sorted(a,val) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - - if (present(val)) then - a%sorted = val - else - a%sorted = .true. - end if - end subroutine psb_lbase_set_sorted - - subroutine psb_lbase_set_triangle(a,val) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - - if (present(val)) then - a%triangle = val - else - a%triangle = .true. - end if - end subroutine psb_lbase_set_triangle - - subroutine psb_lbase_set_unit(a,val) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - - if (present(val)) then - a%unitd = val - else - a%unitd = .true. - end if - end subroutine psb_lbase_set_unit - - subroutine psb_lbase_set_lower(a,val) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - - if (present(val)) then - a%upper = .not.val - else - a%upper = .false. - end if - end subroutine psb_lbase_set_lower - - subroutine psb_lbase_set_upper(a,val) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - - if (present(val)) then - a%upper = val - else - a%upper = .true. - end if - end subroutine psb_lbase_set_upper - - subroutine psb_lbase_set_repeatable_updates(a,val) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - - if (present(val)) then - a%repeatable_updates = val - else - a%repeatable_updates = .true. - end if - end subroutine psb_lbase_set_repeatable_updates - - function psb_lbase_is_triangle(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = a%triangle - end function psb_lbase_is_triangle - - function psb_lbase_is_unit(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = a%unitd - end function psb_lbase_is_unit - - function psb_lbase_is_upper(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = a%upper - end function psb_lbase_is_upper - - function psb_lbase_is_lower(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = .not.a%upper - end function psb_lbase_is_lower - - function psb_lbase_is_null(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = (a%state == psb_spmat_null_) - end function psb_lbase_is_null - - function psb_lbase_is_bld(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = (a%state == psb_spmat_bld_) - end function psb_lbase_is_bld - - function psb_lbase_is_upd(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = (a%state == psb_spmat_upd_) - end function psb_lbase_is_upd - - function psb_lbase_is_asb(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = (a%state == psb_spmat_asb_) - end function psb_lbase_is_asb - - function psb_lbase_is_sorted(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = a%sorted - end function psb_lbase_is_sorted - - - function psb_lbase_is_by_rows(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = .false. - end function psb_lbase_is_by_rows - - function psb_lbase_is_by_cols(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = .false. - end function psb_lbase_is_by_cols - - function psb_lbase_is_repeatable_updates(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - res = a%repeatable_updates - end function psb_lbase_is_repeatable_updates - - - ! - ! TRANSP: note sorted=.false. - ! better invoke a fix() too many than - ! regret it later... - ! - subroutine psb_lbase_transp_2mat(a,b) - implicit none - - class(psb_lbase_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - b%m = a%n - b%n = a%m - b%state = a%state - b%duplicate = a%duplicate - b%triangle = a%triangle - b%unitd = a%unitd - b%upper = .not.a%upper - b%sorted = .false. - b%repeatable_updates = .false. - - end subroutine psb_lbase_transp_2mat - - subroutine psb_lbase_transc_2mat(a,b) - implicit none - - class(psb_lbase_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - - b%m = a%n - b%n = a%m - b%state = a%state - b%duplicate = a%duplicate - b%triangle = a%triangle - b%unitd = a%unitd - b%upper = .not.a%upper - b%sorted = .false. - b%repeatable_updates = .false. - - end subroutine psb_lbase_transc_2mat - - subroutine psb_lbase_transp_1mat(a) - implicit none - - class(psb_lbase_sparse_mat), intent(inout) :: a - integer(psb_lpk_) :: itmp - - itmp = a%m - a%m = a%n - a%n = itmp - a%state = a%state - a%duplicate = a%duplicate - a%triangle = a%triangle - a%unitd = a%unitd - a%upper = .not.a%upper - a%sorted = .false. - a%repeatable_updates = .false. - - end subroutine psb_lbase_transp_1mat - - subroutine psb_lbase_transc_1mat(a) - implicit none - - class(psb_lbase_sparse_mat), intent(inout) :: a - - call a%transp() - end subroutine psb_lbase_transc_1mat - - - - ! - !> Function base_asb: - !! \memberof psb_lbase_sparse_mat - !! \brief Sync: base version calls sync and the set_asb. - !! - ! - subroutine psb_lbase_mat_asb(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - call a%sync() - call a%set_asb() - end subroutine psb_lbase_mat_asb - ! - ! The base version of SYNC & friends does nothing, it's just - ! a placeholder. - ! - ! - !> Function base_sync: - !! \memberof psb_lbase_sparse_mat - !! \brief Sync: base version is a no-op. - !! - ! - subroutine psb_lbase_mat_sync(a) - implicit none - class(psb_lbase_sparse_mat), target, intent(in) :: a - - end subroutine psb_lbase_mat_sync - - ! - !> Function base_set_host: - !! \memberof psb_lbase_sparse_mat - !! \brief Set_host: base version is a no-op. - !! - ! - subroutine psb_lbase_mat_set_host(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - end subroutine psb_lbase_mat_set_host - - ! - !> Function base_set_dev: - !! \memberof psb_lbase_sparse_mat - !! \brief Set_dev: base version is a no-op. - !! - ! - subroutine psb_lbase_mat_set_dev(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - end subroutine psb_lbase_mat_set_dev - - ! - !> Function base_set_sync: - !! \memberof psb_lbase_sparse_mat - !! \brief Set_sync: base version is a no-op. - !! - ! - subroutine psb_lbase_mat_set_sync(a) - implicit none - class(psb_lbase_sparse_mat), intent(inout) :: a - - end subroutine psb_lbase_mat_set_sync - - ! - !> Function base_is_dev: - !! \memberof psb_lbase_sparse_mat - !! \brief Is matrix on eaternal device . - !! - ! - function psb_lbase_mat_is_dev(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - - res = .false. - end function psb_lbase_mat_is_dev - - ! - !> Function base_is_host - !! \memberof psb_lbase_sparse_mat - !! \brief Is matrix on standard memory . - !! - ! - function psb_lbase_mat_is_host(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - - res = .true. - end function psb_lbase_mat_is_host - - ! - !> Function base_is_sync - !! \memberof psb_lbase_sparse_mat - !! \brief Is matrix on sync . - !! - ! - function psb_lbase_mat_is_sync(a) result(res) - implicit none - class(psb_lbase_sparse_mat), intent(in) :: a - logical :: res - - res = .true. - end function psb_lbase_mat_is_sync - -end module psb_lbase_mat_mod - diff --git a/base/modules/serial/psb_ld_base_mat_mod.f90 b/base/modules/serial/psb_ld_base_mat_mod.f90 deleted file mode 100644 index d1a4f192..00000000 --- a/base/modules/serial/psb_ld_base_mat_mod.f90 +++ /dev/null @@ -1,1968 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! -module psb_ld_base_mat_mod - - use psb_lbase_mat_mod - use psb_d_base_vect_mod - - - !> \namespace psb_base_mod \class psb_ld_base_sparse_mat - !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat - !! The psb_ld_base_sparse_mat type, extending psb_lbase_sparse_mat, - !! defines a middle level real(psb_dpk_) sparse matrix object. - !! This class object itself does not have any additional members - !! with respect to those of the base class. Most methods cannot be fully - !! implemented at this level, but we can define the interface for the - !! computational methods requiring the knowledge of the underlying - !! field, such as the matrix-vector product; this interface is defined, - !! but is supposed to be overridden at the leaf level. - !! - !! About the method MOLD: this has been defined for those compilers - !! not yet supporting ALLOCATE( ...,MOLD=...); it's otherwise silly to - !! duplicate "by hand" what is specified in the language (in this case F2008) - !! - type, extends(psb_lbase_sparse_mat) :: psb_ld_base_sparse_mat - contains - ! - ! Data management methods: defined here, but (mostly) not implemented. - ! - procedure, pass(a) :: csput_a => psb_ld_base_csput_a - procedure, pass(a) :: csput_v => psb_ld_base_csput_v - generic, public :: csput => csput_a, csput_v - procedure, pass(a) :: csgetrow => psb_ld_base_csgetrow - procedure, pass(a) :: csgetblk => psb_ld_base_csgetblk - procedure, pass(a) :: get_diag => psb_ld_base_get_diag - generic, public :: csget => csgetrow, csgetblk - procedure, pass(a) :: tril => psb_ld_base_tril - procedure, pass(a) :: triu => psb_ld_base_triu - procedure, pass(a) :: csclip => psb_ld_base_csclip - procedure, pass(a) :: cp_to_coo => psb_ld_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_ld_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_ld_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_ld_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_ld_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_ld_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_ld_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_ld_base_mv_from_fmt - procedure, pass(a) :: mold => psb_ld_base_mold - procedure, pass(a) :: clone => psb_ld_base_clone - procedure, pass(a) :: make_nonunit => psb_ld_base_make_nonunit - procedure, pass(a) :: clean_zeros => psb_ld_base_clean_zeros - - ! - ! Transpose methods: defined here but not implemented. - ! - procedure, pass(a) :: transp_1mat => psb_ld_base_transp_1mat - procedure, pass(a) :: transp_2mat => psb_ld_base_transp_2mat - procedure, pass(a) :: transc_1mat => psb_ld_base_transc_1mat - procedure, pass(a) :: transc_2mat => psb_ld_base_transc_2mat - - ! - ! Computational methods: defined here but not implemented. - ! - procedure, pass(a) :: vect_mv => psb_ld_base_vect_mv - procedure, pass(a) :: csmv => psb_ld_base_csmv - procedure, pass(a) :: csmm => psb_ld_base_csmm - generic, public :: spmm => csmm, csmv, vect_mv - procedure, pass(a) :: in_vect_sv => psb_ld_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_ld_base_inner_cssv - procedure, pass(a) :: inner_cssm => psb_ld_base_inner_cssm - generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv - procedure, pass(a) :: vect_cssv => psb_ld_base_vect_cssv - procedure, pass(a) :: cssv => psb_ld_base_cssv - procedure, pass(a) :: cssm => psb_ld_base_cssm - generic, public :: spsm => cssm, cssv, vect_cssv - procedure, pass(a) :: scals => psb_ld_base_scals - procedure, pass(a) :: scalv => psb_ld_base_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: maxval => psb_ld_base_maxval - procedure, pass(a) :: spnmi => psb_ld_base_csnmi - procedure, pass(a) :: spnm1 => psb_ld_base_csnm1 - procedure, pass(a) :: rowsum => psb_ld_base_rowsum - procedure, pass(a) :: arwsum => psb_ld_base_arwsum - procedure, pass(a) :: colsum => psb_ld_base_colsum - procedure, pass(a) :: aclsum => psb_ld_base_aclsum - end type psb_ld_base_sparse_mat - - private :: ld_base_mat_sync, ld_base_mat_is_host, ld_base_mat_is_dev, & - & ld_base_mat_is_sync, ld_base_mat_set_host, ld_base_mat_set_dev,& - & ld_base_mat_set_sync - - !> \namespace psb_base_mod \class psb_ld_coo_sparse_mat - !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat - !! - !! psb_ld_coo_sparse_mat type and the related methods. This is the - !! reference type for all the format transitions, copies and mv unless - !! methods are implemented that allow the direct transition from one - !! format to another. It is defined here since all other classes must - !! refer to it per the MEDIATOR design pattern. - !! - type, extends(psb_ld_base_sparse_mat) :: psb_ld_coo_sparse_mat - !> Number of nonzeros. - integer(psb_lpk_) :: nnz - !> Row indices. - integer(psb_lpk_), allocatable :: ia(:) - !> Column indices. - integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. - real(psb_dpk_), allocatable :: val(:) - - integer, private :: sort_status=psb_unsorted_ - - contains - ! - ! Data management methods. - ! - procedure, pass(a) :: get_size => ld_coo_get_size - procedure, pass(a) :: get_nzeros => ld_coo_get_nzeros - procedure, nopass :: get_fmt => ld_coo_get_fmt - procedure, pass(a) :: sizeof => ld_coo_sizeof - procedure, pass(a) :: reallocate_nz => psb_ld_coo_reallocate_nz - procedure, pass(a) :: allocate_mnnz => psb_ld_coo_allocate_mnnz - procedure, pass(a) :: cp_to_coo => psb_ld_cp_coo_to_coo - procedure, pass(a) :: cp_from_coo => psb_ld_cp_coo_from_coo - procedure, pass(a) :: cp_to_fmt => psb_ld_cp_coo_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_ld_cp_coo_from_fmt - procedure, pass(a) :: mv_to_coo => psb_ld_mv_coo_to_coo - procedure, pass(a) :: mv_from_coo => psb_ld_mv_coo_from_coo - procedure, pass(a) :: mv_to_fmt => psb_ld_mv_coo_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_ld_mv_coo_from_fmt - procedure, pass(a) :: csput_a => psb_ld_coo_csput_a - procedure, pass(a) :: get_diag => psb_ld_coo_get_diag - procedure, pass(a) :: csgetrow => psb_ld_coo_csgetrow - procedure, pass(a) :: csgetptn => psb_ld_coo_csgetptn - procedure, pass(a) :: reinit => psb_ld_coo_reinit - procedure, pass(a) :: get_nz_row => psb_ld_coo_get_nz_row - procedure, pass(a) :: fix => psb_ld_fix_coo - procedure, pass(a) :: trim => psb_ld_coo_trim - procedure, pass(a) :: clean_zeros => psb_ld_coo_clean_zeros - procedure, pass(a) :: print => psb_ld_coo_print - procedure, pass(a) :: free => ld_coo_free - procedure, pass(a) :: mold => psb_ld_coo_mold - procedure, pass(a) :: is_sorted => ld_coo_is_sorted - procedure, pass(a) :: is_by_rows => ld_coo_is_by_rows - procedure, pass(a) :: is_by_cols => ld_coo_is_by_cols - procedure, pass(a) :: set_by_rows => ld_coo_set_by_rows - procedure, pass(a) :: set_by_cols => ld_coo_set_by_cols - procedure, pass(a) :: set_sort_status => ld_coo_set_sort_status - procedure, pass(a) :: get_sort_status => ld_coo_get_sort_status - - ! - ! This is COO specific - ! - procedure, pass(a) :: set_nzeros => ld_coo_set_nzeros - - ! - ! Transpose methods. These are the base of all - ! indirection in transpose, together with conversions - ! they are sufficient for all cases. - ! - procedure, pass(a) :: transp_1mat => ld_coo_transp_1mat - procedure, pass(a) :: transc_1mat => ld_coo_transc_1mat - - ! - ! Computational methods. - ! - procedure, pass(a) :: csmm => psb_ld_coo_csmm - procedure, pass(a) :: csmv => psb_ld_coo_csmv - procedure, pass(a) :: inner_cssm => psb_ld_coo_cssm - procedure, pass(a) :: inner_cssv => psb_ld_coo_cssv - procedure, pass(a) :: scals => psb_ld_coo_scals - procedure, pass(a) :: scalv => psb_ld_coo_scal - procedure, pass(a) :: maxval => psb_ld_coo_maxval - procedure, pass(a) :: spnmi => psb_ld_coo_csnmi - procedure, pass(a) :: spnm1 => psb_ld_coo_csnm1 - procedure, pass(a) :: rowsum => psb_ld_coo_rowsum - procedure, pass(a) :: arwsum => psb_ld_coo_arwsum - procedure, pass(a) :: colsum => psb_ld_coo_colsum - procedure, pass(a) :: aclsum => psb_ld_coo_aclsum - - end type psb_ld_coo_sparse_mat - - private :: ld_coo_get_nzeros, ld_coo_set_nzeros, & - & ld_coo_get_fmt, ld_coo_free, ld_coo_sizeof, & - & ld_coo_transp_1mat, ld_coo_transc_1mat - - - - ! == ================= - ! - ! BASE interfaces - ! - ! == ================= - - !> Function csput: - !! \memberof psb_ld_base_sparse_mat - !! \brief Insert coefficients. - !! - !! - !! Given a list of NZ triples - !! (IA(i),JA(i),VAL(i)) - !! record a new coefficient in A such that - !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! - !! The internal components IA,JA,VAL are reallocated as necessary. - !! Constraints: - !! - If the matrix A is in the BUILD state, then the method will - !! only work for COO matrices, all other format will throw an error. - !! In this case coefficients are queued inside A for further processing. - !! - If the matrix A is in the UPDATE state, then it can be in any format; - !! the update operation will perform either - !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ) - !! or - !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) - !! according to the value of DUPLICATE. - !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! - !! \param nz number of triples in input - !! \param ia(:) the input row indices - !! \param ja(:) the input col indices - !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index - !! \param info return code - !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) - !! - ! - interface - subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - end subroutine psb_ld_base_csput_a - end interface - - interface - subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_base_vect_type), intent(inout) :: val - class(psb_i_base_vect_type), intent(inout) :: ia, ja - integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - end subroutine psb_ld_base_csput_v - end interface - - ! - ! - !> Function csgetrow: - !! \memberof psb_ld_base_sparse_mat - !! \brief Get a (subset of) row(s) - !! - !! getrow is the basic method by which the other (getblk, clip) can - !! be implemented. - !! - !! Returns the set - !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) - !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; - !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in - !! \param nz the number of output coefficients - !! \param ia(:) the output row indices - !! \param ja(:) the output col indices - !! \param val(:) the output coefficients - !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index - !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) - !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] - !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] - !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja - !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! - ! - interface - subroutine psb_ld_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_base_csgetrow - end interface - - ! - !> Function csgetblk: - !! \memberof psb_ld_base_sparse_mat - !! \brief Get a (subset of) row(s) - !! - !! getblk is very similar to getrow, except that the output - !! is packaged in a psb_ld_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in - !! \param b the output (sub)matrix - !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index - !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) - !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] - !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] - !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja - !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! - ! - interface - subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_base_csgetblk - end interface - - ! - ! - !> Function csclip: - !! \memberof psb_ld_base_sparse_mat - !! \brief Get a submatrix. - !! - !! csclip is practically identical to getblk. - !! One of them has to go away..... - !! - !! \param b the output submatrix - !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index - !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) - !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] - !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] - !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja - !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! - ! - interface - subroutine psb_ld_base_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_base_csclip - end interface - ! - !> Function tril: - !! \memberof psb_ld_base_sparse_mat - !! \brief Copy the lower triangle, i.e. all entries - !! A(I,J) such that J-I <= DIAG - !! default value is DIAG=0, i.e. lower triangle up to - !! the main diagonal. - !! DIAG=-1 means copy the strictly lower triangle - !! DIAG= 1 means copy the lower triangle plus the first diagonal - !! of the upper triangle. - !! Moreover, apply a clipping by copying entries A(I,J) only if - !! IMIN<=I<=IMAX - !! JMIN<=J<=JMAX - !! - !! \param l the output (sub)matrix - !! \param info return code - !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index - !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) - !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] - !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] - !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja - !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! \param u [none] copy of the complementary triangle - !! - ! - interface - subroutine psb_ld_base_tril(a,l,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,u) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(out) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ld_coo_sparse_mat), optional, intent(out) :: u - end subroutine psb_ld_base_tril - end interface - - ! - !> Function triu: - !! \memberof psb_ld_base_sparse_mat - !! \brief Copy the upper triangle, i.e. all entries - !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from - !! the main diagonal up. - !! DIAG= 1 means copy the strictly upper triangle - !! DIAG=-1 means copy the upper triangle plus the first diagonal - !! of the lower triangle. - !! Moreover, apply a clipping by copying entries A(I,J) only if - !! IMIN<=I<=IMAX - !! JMIN<=J<=JMAX - !! Optionally copies the lower triangle at the same time - !! - !! \param u the output (sub)matrix - !! \param info return code - !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index - !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) - !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] - !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] - !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja - !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! \param l [none] copy of the complementary triangle - !! - ! - interface - subroutine psb_ld_base_triu(a,u,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,l) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(out) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ld_coo_sparse_mat), optional, intent(out) :: l - end subroutine psb_ld_base_triu - end interface - - - ! - !> Function get_diag: - !! \memberof psb_ld_base_sparse_mat - !! \brief Extract the diagonal of A. - !! - !! D(i) = A(i:i), i=1:min(nrows,ncols) - !! - !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_ld_base_get_diag(a,d,info) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_get_diag - end interface - - ! - !> Function mold: - !! \memberof psb_ld_base_sparse_mat - !! \brief Allocate a class(psb_ld_base_sparse_mat) with the - !! same dynamic type as the input. - !! This is equivalent to allocate( mold= ) and is provided - !! for those compilers not yet supporting mold. - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_mold(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_mold - end interface - - ! - ! - !> Function clone: - !! \memberof psb_ld_base_sparse_mat - !! \brief Allocate and clone a class(psb_ld_base_sparse_mat) with the - !! same dynamic type as the input. - !! This is equivalent to allocate( source= ) except that - !! it should guarantee a deep copy wherever needed. - !! Should also be equivalent to calling mold and then copy, - !! but it can also be implemented by default using cp_to_fmt. - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_clone(a,b, info) - import - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_clone - end interface - - - ! - ! - !> Function make_nonunit: - !! \memberof psb_ld_base_make_nonunit - !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. - !! This is needed e.g. when scaling - ! - interface - subroutine psb_ld_base_make_nonunit(a) - import - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - end subroutine psb_ld_base_make_nonunit - end interface - - - ! - !> Function cp_to_coo: - !! \memberof psb_ld_base_sparse_mat - !! \brief Copy and convert to psb_ld_coo_sparse_mat - !! Invoked from the source object. - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_cp_to_coo(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_cp_to_coo - end interface - - ! - !> Function cp_from_coo: - !! \memberof psb_ld_base_sparse_mat - !! \brief Copy and convert from psb_ld_coo_sparse_mat - !! Invoked from the target object. - !! \param b The input variable - !! \param info return code - ! - interface - subroutine psb_ld_base_cp_from_coo(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_cp_from_coo - end interface - - ! - !> Function cp_to_fmt: - !! \memberof psb_ld_base_sparse_mat - !! \brief Copy and convert to a class(psb_ld_base_sparse_mat) - !! Invoked from the source object. Can be implemented by - !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_cp_to_fmt(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_cp_to_fmt - end interface - - ! - !> Function cp_from_fmt: - !! \memberof psb_ld_base_sparse_mat - !! \brief Copy and convert from a class(psb_ld_base_sparse_mat) - !! Invoked from the target object. Can be implemented by - !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_cp_from_fmt(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_cp_from_fmt - end interface - - ! - !> Function mv_to_coo: - !! \memberof psb_ld_base_sparse_mat - !! \brief Convert to psb_ld_coo_sparse_mat, freeing the source. - !! Invoked from the source object. - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_mv_to_coo(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_mv_to_coo - end interface - - ! - !> Function mv_from_coo: - !! \memberof psb_ld_base_sparse_mat - !! \brief Convert from psb_ld_coo_sparse_mat, freeing the source. - !! Invoked from the target object. - !! \param b The input variable - !! \param info return code - ! - interface - subroutine psb_ld_base_mv_from_coo(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_mv_from_coo - end interface - - ! - !> Function mv_to_fmt: - !! \memberof psb_ld_base_sparse_mat - !! \brief Convert to a class(psb_ld_base_sparse_mat), freeing the source. - !! Invoked from the source object. Can be implemented by - !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_mv_to_fmt(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_mv_to_fmt - end interface - - ! - !> Function mv_from_fmt: - !! \memberof psb_ld_base_sparse_mat - !! \brief Convert from a class(psb_ld_base_sparse_mat), freeing the source. - !! Invoked from the target object. Can be implemented by - !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). - !! \param b The output variable - !! \param info return code - ! - interface - subroutine psb_ld_base_mv_from_fmt(a,b,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_mv_from_fmt - end interface - ! - !> - !! \memberof psb_ld_base_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros - ! - interface - subroutine psb_ld_base_clean_zeros(a, info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_clean_zeros - end interface - - ! - !> Function transp: - !! \memberof psb_ld_base_sparse_mat - !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. - !! Copyout version - !! \param b The output variable - ! - interface - subroutine psb_ld_base_transp_2mat(a,b) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - end subroutine psb_ld_base_transp_2mat - end interface - - ! - !> Function transc: - !! \memberof psb_ld_base_sparse_mat - !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. - !! Copyout version. - !! \param b The output variable - ! - interface - subroutine psb_ld_base_transc_2mat(a,b) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - end subroutine psb_ld_base_transc_2mat - end interface - - ! - !> Function transp: - !! \memberof psb_ld_base_sparse_mat - !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. - !! In-place version. - ! - interface - subroutine psb_ld_base_transp_1mat(a) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - end subroutine psb_ld_base_transp_1mat - end interface - - ! - !> Function transc: - !! \memberof psb_ld_base_sparse_mat - !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. - !! In-place version. - ! - interface - subroutine psb_ld_base_transc_1mat(a) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - end subroutine psb_ld_base_transc_1mat - end interface - - ! - !> Function csmm: - !! \memberof psb_ld_base_sparse_mat - !! \brief Product by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! - ! - interface - subroutine psb_ld_base_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_csmm - end interface - - !> Function csmv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Product by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! - ! - interface - subroutine psb_ld_base_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_csmv - end interface - - !> Function vect_mv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Product by an encapsulated array type(psb_ld_vect_type) - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! Usually the unwrapping of the encapsulated vector is done - !! here, so that all the derived classes need only the - !! versions with the standard arrays. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input X - !! \param beta Scaling factor for y - !! \param y the input/output Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! - ! - interface - subroutine psb_ld_base_vect_mv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_vect_mv - end interface - - ! - !> Function cssm: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssm. - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! - ! - interface - subroutine psb_ld_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_inner_cssm - end interface - - - ! - !> Function cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssv. - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ld_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_inner_cssv - end interface - - ! - !> Function inner_vect_cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_ld_vect_type) - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by vect_cssv. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - ! - interface - subroutine psb_ld_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_inner_vect_sv - end interface - - ! - !> Function cssm: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ld_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_ld_base_cssm - end interface - - ! - !> Function cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ld_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_ld_base_cssv - end interface - - ! - !> Function vect_cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_ld_vect_type) - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ld_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_d_base_vect_type), optional, intent(inout) :: d - end subroutine psb_ld_base_vect_cssv - end interface - - ! - !> Function base_scals: - !! \memberof psb_ld_base_sparse_mat - !! \brief Scale a matrix by a single scalar value - !! - !! \param d Scaling factor - !! \param info return code - ! - interface - subroutine psb_ld_base_scals(d,a,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_scals - end interface - - ! - !> Function base_scal: - !! \memberof psb_ld_base_sparse_mat - !! \brief Scale a matrix by a vector - !! - !! \param d(:) Scaling vector - !! \param info return code - !! \param side [L] Scale on the Left (rows) or on the Right (columns) - ! - interface - subroutine psb_ld_base_scal(d,a,info,side) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_ld_base_scal - end interface - - ! - !> Function base_maxval: - !! \memberof psb_ld_base_sparse_mat - !! \brief Maximum absolute value of all coefficients; - !! - ! - interface - function psb_ld_base_maxval(a) result(res) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_base_maxval - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_ld_base_sparse_mat - !! \brief Operator infinity norm - !! - ! - interface - function psb_ld_base_csnmi(a) result(res) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_base_csnmi - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_ld_base_sparse_mat - !! \brief Operator 1-norm - !! - ! - interface - function psb_ld_base_csnm1(a) result(res) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_base_csnm1 - end interface - - ! - ! - !> Function base_rowsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Sum along the rows - !! \param d(:) The output row sums - !! - ! - interface - subroutine psb_ld_base_rowsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_rowsum - end interface - - ! - !> Function base_arwsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Absolute value sum along the rows - !! \param d(:) The output row sums - !! - interface - subroutine psb_ld_base_arwsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_arwsum - end interface - - ! - ! - !> Function base_colsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Sum along the columns - !! \param d(:) The output col sums - !! - ! - interface - subroutine psb_ld_base_colsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_colsum - end interface - - ! - !> Function base_aclsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Absolute value sum along the columns - !! \param d(:) The output col sums - !! - interface - subroutine psb_ld_base_aclsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_aclsum - end interface - - - ! == =============== - ! - ! COO interfaces - ! - ! == =============== - - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_lbase_mat_mod::psb_base_reallocate_nz - ! - interface - subroutine psb_ld_coo_reallocate_nz(nz,a) - import - integer(psb_lpk_), intent(in) :: nz - class(psb_ld_coo_sparse_mat), intent(inout) :: a - end subroutine psb_ld_coo_reallocate_nz - end interface - - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_lbase_mat_mod::psb_base_reinit - ! - interface - subroutine psb_ld_coo_reinit(a,clear) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_ld_coo_reinit - end interface - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_lbase_mat_mod::psb_base_trim - ! - interface - subroutine psb_ld_coo_trim(a) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - end subroutine psb_ld_coo_trim - end interface - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros - ! - interface - subroutine psb_ld_coo_clean_zeros(a,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_coo_clean_zeros - end interface - - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_lbase_mat_mod::psb_base_allocate_mnnz - ! - interface - subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) - import - integer(psb_lpk_), intent(in) :: m,n - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_ld_coo_allocate_mnnz - end interface - - - !> \memberof psb_ld_coo_sparse_mat - !| \see psb_lbase_mat_mod::psb_base_mold - interface - subroutine psb_ld_coo_mold(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_coo_mold - end interface - - - ! - !> Function print. - !! \memberof psb_ld_coo_sparse_mat - !! \brief Print the matrix to file in MatrixMarket format - !! - !! \param iout The unit to write to - !! \param iv [none] Renumbering for both rows and columns - !! \param head [none] Descriptive header for the file - !! \param ivr [none] Row renumbering - !! \param ivc [none] Col renumbering - !! - ! - interface - subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) - import - integer(psb_ipk_), intent(in) :: iout - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_ld_coo_print - end interface - - - - ! - !> Function get_nz_row. - !! \memberof psb_ld_coo_sparse_mat - !! \brief How many nonzeros in a row? - !! - !! \param idx The row to search. - !! - ! - interface - function psb_ld_coo_get_nz_row(idx,a) result(res) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_) :: res - end function psb_ld_coo_get_nz_row - end interface - - - ! - !> Funtion: fix_coo_inner - !! \brief Make sure the entries are sorted and duplicates are handled. - !! Used internally by fix_coo - !! \param nzin Number of entries on input to be handled - !! \param dupl What to do with duplicated entries. - !! \param ia(:) Row indices - !! \param ja(:) Col indices - !! \param val(:) Coefficients - !! \param nzout Number of entries after sorting/duplicate handling - !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! - ! - interface - subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import - integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl - integer(psb_lpk_), intent(inout) :: ia(:), ja(:) - real(psb_dpk_), intent(inout) :: val(:) - integer(psb_lpk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - end subroutine psb_ld_fix_coo_inner - end interface - - ! - !> Function fix_coo - !! \memberof psb_ld_coo_sparse_mat - !! \brief Make sure the entries are sorted and duplicates are handled. - !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! - ! - interface - subroutine psb_ld_fix_coo(a,info,idir) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - end subroutine psb_ld_fix_coo - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo - interface - subroutine psb_ld_cp_coo_to_coo(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_coo_to_coo - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - interface - subroutine psb_ld_cp_coo_from_coo(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_coo_from_coo - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - !! - interface - subroutine psb_ld_cp_coo_to_fmt(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_coo_to_fmt - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt - !! - interface - subroutine psb_ld_cp_coo_from_fmt(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_coo_from_fmt - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo - interface - subroutine psb_ld_mv_coo_to_coo(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_coo_to_coo - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo - interface - subroutine psb_ld_mv_coo_from_coo(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_coo_from_coo - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt - interface - subroutine psb_ld_mv_coo_to_fmt(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_coo_to_fmt - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt - interface - subroutine psb_ld_mv_coo_from_fmt(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_coo_from_fmt - end interface - - interface - subroutine psb_ld_coo_cp_from(a,b) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - type(psb_ld_coo_sparse_mat), intent(in) :: b - end subroutine psb_ld_coo_cp_from - end interface - - interface - subroutine psb_ld_coo_mv_from(a,b) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - type(psb_ld_coo_sparse_mat), intent(inout) :: b - end subroutine psb_ld_coo_mv_from - end interface - - - !> Function csput - !! \memberof psb_ld_coo_sparse_mat - !! \brief Add coefficients into the matrix. - !! - !! \param nz Number of entries to be added - !! \param ia(:) Row indices - !! \param ja(:) Col indices - !! \param val(:) Values - !! \param imin Minimum row index to accept - !! \param imax Maximum row index to accept - !! \param jmin Minimum col index to accept - !! \param jmax Maximum col index to accept - !! \param info return code - !! \param gtl [none] Renumbering for rows/columns - !! - ! - interface - subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& - & imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - end subroutine psb_ld_coo_csput_a - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_lbase_mat_mod::psb_base_csgetptn - interface - subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_coo_csgetptn - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow - interface - subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_coo_csgetrow - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssv - interface - subroutine psb_ld_coo_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_cssv - end interface - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssm - interface - subroutine psb_ld_coo_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_cssm - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmv - interface - subroutine psb_ld_coo_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_csmv - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmm - interface - subroutine psb_ld_coo_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_csmm - end interface - - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_maxval - interface - function psb_ld_coo_maxval(a) result(res) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_coo_maxval - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csnmi - interface - function psb_ld_coo_csnmi(a) result(res) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_coo_csnmi - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csnm1 - interface - function psb_ld_coo_csnm1(a) result(res) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_coo_csnm1 - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_rowsum - interface - subroutine psb_ld_coo_rowsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_rowsum - end interface - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_arwsum - interface - subroutine psb_ld_coo_arwsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_arwsum - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_colsum - interface - subroutine psb_ld_coo_colsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_colsum - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_aclsum - interface - subroutine psb_ld_coo_aclsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_aclsum - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag - interface - subroutine psb_ld_coo_get_diag(a,d,info) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_coo_get_diag - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_scal - interface - subroutine psb_ld_coo_scal(d,a,info,side) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_ld_coo_scal - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_scals - interface - subroutine psb_ld_coo_scals(d,a,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_coo_scals - end interface - - -contains - - - ! == ================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == ================================== - - - - function ld_coo_sizeof(a) result(res) - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_epk_) :: res - res = 8 + 1 - res = res + psb_sizeof_dp * psb_size(a%val) - res = res + psb_sizeof_ip * psb_size(a%ia) - res = res + psb_sizeof_ip * psb_size(a%ja) - - end function ld_coo_sizeof - - - function ld_coo_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'COO' - end function ld_coo_get_fmt - - - function ld_coo_get_size(a) result(res) - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - res = -1 - - if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then - res = min(res,size(a%ja)) - else - res = size(a%ja) - end if - end if - if (allocated(a%val)) then - if (res >= 0) then - res = min(res,size(a%val)) - else - res = size(a%val) - end if - end if - end function ld_coo_get_size - - - function ld_coo_get_nzeros(a) result(res) - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - res = a%nnz - end function ld_coo_get_nzeros - - function ld_coo_is_by_rows(a) result(res) - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - logical :: res - res = (a%sort_status == psb_row_major_) - end function ld_coo_is_by_rows - - function ld_coo_is_by_cols(a) result(res) - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - logical :: res - res = (a%sort_status == psb_col_major_) - end function ld_coo_is_by_cols - - function ld_coo_is_sorted(a) result(res) - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - logical :: res - res = (a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_) - end function ld_coo_is_sorted - - - - ! == ================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - ! == ================================== - - subroutine ld_coo_set_nzeros(nz,a) - implicit none - integer(psb_lpk_), intent(in) :: nz - class(psb_ld_coo_sparse_mat), intent(inout) :: a - - a%nnz = nz - - end subroutine ld_coo_set_nzeros - - function ld_coo_get_sort_status(a) result(res) - implicit none - integer(psb_ipk_) :: res - class(psb_ld_coo_sparse_mat), intent(in) :: a - - res = a%sort_status - end function ld_coo_get_sort_status - - subroutine ld_coo_set_sort_status(ist,a) - implicit none - integer(psb_ipk_), intent(in) :: ist - class(psb_ld_coo_sparse_mat), intent(inout) :: a - - a%sort_status = ist - call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) - end subroutine ld_coo_set_sort_status - - - subroutine ld_coo_set_by_rows(a) - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - - a%sort_status = psb_row_major_ - call a%set_sorted() - end subroutine ld_coo_set_by_rows - - - subroutine ld_coo_set_by_cols(a) - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - - a%sort_status = psb_col_major_ - call a%set_sorted() - end subroutine ld_coo_set_by_cols - - ! == ================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - ! == ================================== - - subroutine ld_coo_free(a) - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - - if (allocated(a%ia)) deallocate(a%ia) - if (allocated(a%ja)) deallocate(a%ja) - if (allocated(a%val)) deallocate(a%val) - call a%set_null() - call a%set_nrows(0_psb_lpk_) - call a%set_ncols(0_psb_lpk_) - call a%set_nzeros(0_psb_lpk_) - call a%set_sort_status(psb_unsorted_) - - return - - end subroutine ld_coo_free - - - - ! == ================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - ! == ================================== - subroutine ld_coo_transp_1mat(a) - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - - integer(psb_lpk_), allocatable :: itemp(:) - integer(psb_ipk_) :: info - - call a%psb_ld_base_sparse_mat%psb_lbase_sparse_mat%transp() - call move_alloc(a%ia,itemp) - call move_alloc(a%ja,a%ia) - call move_alloc(itemp,a%ja) - - call a%set_sorted(.false.) - call a%set_sort_status(psb_unsorted_) - - return - - end subroutine ld_coo_transp_1mat - - subroutine ld_coo_transc_1mat(a) - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - - call a%transp() - ! This will morph into conjg() for C and Z - ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. - if (psb_ld_is_complex_) a%val(:) = (a%val(:)) - - end subroutine ld_coo_transc_1mat - - -end module psb_ld_base_mat_mod - - - diff --git a/base/modules/serial/psb_ld_csc_mat_mod.f90 b/base/modules/serial/psb_ld_csc_mat_mod.f90 deleted file mode 100644 index 4e1e7250..00000000 --- a/base/modules/serial/psb_ld_csc_mat_mod.f90 +++ /dev/null @@ -1,612 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_ld_csc_mat_mod -! -! This module contains the definition of the psb_ld_csc_sparse_mat type -! which implements an actual storage format (the CSC in this case) for -! a sparse matrix as well as the related methods (those who are -! specific to the type and could not be defined higher in the -! hierarchy). We are at the bottom level of the inheritance chain. -! -! Please refere to psb_ld_base_mat_mod for a detailed description -! of the various methods, and to psb_ld_csc_impl for implementation details. -! -module psb_ld_csc_mat_mod - - use psb_ld_base_mat_mod - - !> \namespace psb_base_mod \class psb_ld_csc_sparse_mat - !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat - !! - !! psb_ld_csc_sparse_mat type and the related methods. - !! - type, extends(psb_ld_base_sparse_mat) :: psb_ld_csc_sparse_mat - - !> Pointers to beginning of cols in IA and VAL. - integer(psb_lpk_), allocatable :: icp(:) - !> Row indices. - integer(psb_lpk_), allocatable :: ia(:) - !> Coefficient values. - real(psb_dpk_), allocatable :: val(:) - - contains - procedure, pass(a) :: is_by_cols => ld_csc_is_by_cols - procedure, pass(a) :: get_size => ld_csc_get_size - procedure, pass(a) :: get_nzeros => ld_csc_get_nzeros - procedure, nopass :: get_fmt => ld_csc_get_fmt - procedure, pass(a) :: sizeof => ld_csc_sizeof - procedure, pass(a) :: csmm => psb_ld_csc_csmm - procedure, pass(a) :: csmv => psb_ld_csc_csmv - procedure, pass(a) :: inner_cssm => psb_ld_csc_cssm - procedure, pass(a) :: inner_cssv => psb_ld_csc_cssv - procedure, pass(a) :: scals => psb_ld_csc_scals - procedure, pass(a) :: scalv => psb_ld_csc_scal - procedure, pass(a) :: maxval => psb_ld_csc_maxval - procedure, pass(a) :: spnm1 => psb_ld_csc_csnm1 - procedure, pass(a) :: rowsum => psb_ld_csc_rowsum - procedure, pass(a) :: arwsum => psb_ld_csc_arwsum - procedure, pass(a) :: colsum => psb_ld_csc_colsum - procedure, pass(a) :: aclsum => psb_ld_csc_aclsum - procedure, pass(a) :: reallocate_nz => psb_ld_csc_reallocate_nz - procedure, pass(a) :: allocate_mnnz => psb_ld_csc_allocate_mnnz - procedure, pass(a) :: cp_to_coo => psb_ld_cp_csc_to_coo - procedure, pass(a) :: cp_from_coo => psb_ld_cp_csc_from_coo - procedure, pass(a) :: cp_to_fmt => psb_ld_cp_csc_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_ld_cp_csc_from_fmt - procedure, pass(a) :: mv_to_coo => psb_ld_mv_csc_to_coo - procedure, pass(a) :: mv_from_coo => psb_ld_mv_csc_from_coo - procedure, pass(a) :: mv_to_fmt => psb_ld_mv_csc_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_ld_mv_csc_from_fmt - procedure, pass(a) :: csput_a => psb_ld_csc_csput_a - procedure, pass(a) :: get_diag => psb_ld_csc_get_diag - procedure, pass(a) :: csgetptn => psb_ld_csc_csgetptn - procedure, pass(a) :: csgetrow => psb_ld_csc_csgetrow - procedure, pass(a) :: get_nz_col => ld_csc_get_nz_col - procedure, pass(a) :: reinit => psb_ld_csc_reinit - procedure, pass(a) :: trim => psb_ld_csc_trim - procedure, pass(a) :: print => psb_ld_csc_print - procedure, pass(a) :: free => ld_csc_free - procedure, pass(a) :: mold => psb_ld_csc_mold - - end type psb_ld_csc_sparse_mat - - private :: ld_csc_get_nzeros, ld_csc_free, ld_csc_get_fmt, & - & ld_csc_get_size, ld_csc_sizeof, ld_csc_get_nz_col - - !> \memberof psb_ld_csc_sparse_mat - !| \see psb_base_mat_mod::psb_base_reallocate_nz - interface - subroutine psb_ld_csc_reallocate_nz(nz,a) - import - integer(psb_lpk_), intent(in) :: nz - class(psb_ld_csc_sparse_mat), intent(inout) :: a - end subroutine psb_ld_csc_reallocate_nz - end interface - - !> \memberof psb_ld_csc_sparse_mat - !| \see psb_base_mat_mod::psb_base_reinit - interface - subroutine psb_ld_csc_reinit(a,clear) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_ld_csc_reinit - end interface - - !> \memberof psb_ld_csc_sparse_mat - !| \see psb_base_mat_mod::psb_base_trim - interface - subroutine psb_ld_csc_trim(a) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - end subroutine psb_ld_csc_trim - end interface - - !> \memberof psb_ld_csc_sparse_mat - !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ld_csc_mold(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_csc_mold - end interface - - !> \memberof psb_ld_csc_sparse_mat - !| \see psb_base_mat_mod::psb_base_allocate_mnnz - interface - subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) - import - integer(psb_lpk_), intent(in) :: m,n - class(psb_ld_csc_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_ld_csc_allocate_mnnz - end interface - - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_print - interface - subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc) - import - integer(psb_ipk_), intent(in) :: iout - class(psb_ld_csc_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_ld_csc_print - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo - interface - subroutine psb_ld_cp_csc_to_coo(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csc_to_coo - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - interface - subroutine psb_ld_cp_csc_from_coo(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csc_from_coo - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_fmt - interface - subroutine psb_ld_cp_csc_to_fmt(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csc_to_fmt - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt - interface - subroutine psb_ld_cp_csc_from_fmt(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csc_from_fmt - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo - interface - subroutine psb_ld_mv_csc_to_coo(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csc_to_coo - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo - interface - subroutine psb_ld_mv_csc_from_coo(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csc_from_coo - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt - interface - subroutine psb_ld_mv_csc_to_fmt(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csc_to_fmt - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt - interface - subroutine psb_ld_mv_csc_from_fmt(a,b,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csc_from_fmt - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from - interface - subroutine psb_ld_csc_cp_from(a,b) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - type(psb_ld_csc_sparse_mat), intent(in) :: b - end subroutine psb_ld_csc_cp_from - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from - interface - subroutine psb_ld_csc_mv_from(a,b) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - type(psb_ld_csc_sparse_mat), intent(inout) :: b - end subroutine psb_ld_csc_mv_from - end interface - - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a - interface - subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& - & imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - end subroutine psb_ld_csc_csput_a - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_base_mat_mod::psb_base_csgetptn - interface - subroutine psb_ld_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csc_csgetptn - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow - interface - subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csc_csgetrow - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csgetblk - interface - subroutine psb_ld_csc_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csc_csgetblk - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssv - interface - subroutine psb_ld_csc_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csc_cssv - end interface - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssm - interface - subroutine psb_ld_csc_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csc_cssm - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmv - interface - subroutine psb_ld_csc_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csc_csmv - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmm - interface - subroutine psb_ld_csc_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csc_csmm - end interface - - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_maxval - interface - function psb_ld_csc_maxval(a) result(res) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_csc_maxval - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csnm1 - interface - function psb_ld_csc_csnm1(a) result(res) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_csc_csnm1 - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_rowsum - interface - subroutine psb_ld_csc_rowsum(d,a) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csc_rowsum - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_arwsum - interface - subroutine psb_ld_csc_arwsum(d,a) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csc_arwsum - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_colsum - interface - subroutine psb_ld_csc_colsum(d,a) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csc_colsum - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_aclsum - interface - subroutine psb_ld_csc_aclsum(d,a) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csc_aclsum - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag - interface - subroutine psb_ld_csc_get_diag(a,d,info) - import - class(psb_ld_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_csc_get_diag - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_scal - interface - subroutine psb_ld_csc_scal(d,a,info,side) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_ld_csc_scal - end interface - - !> \memberof psb_ld_csc_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_scals - interface - subroutine psb_ld_csc_scals(d,a,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_csc_scals - end interface - - -contains - - ! == =================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == =================================== - - - function ld_csc_is_by_cols(a) result(res) - implicit none - class(psb_ld_csc_sparse_mat), intent(in) :: a - logical :: res - res = .true. - - end function ld_csc_is_by_cols - - - function ld_csc_sizeof(a) result(res) - implicit none - class(psb_ld_csc_sparse_mat), intent(in) :: a - integer(psb_epk_) :: res - res = 8 - res = res + psb_sizeof_dp * psb_size(a%val) - res = res + psb_sizeof_ip * psb_size(a%icp) - res = res + psb_sizeof_ip * psb_size(a%ia) - - end function ld_csc_sizeof - - function ld_csc_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'CSC' - end function ld_csc_get_fmt - - function ld_csc_get_nzeros(a) result(res) - implicit none - class(psb_ld_csc_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - res = a%icp(a%get_ncols()+1)-1 - end function ld_csc_get_nzeros - - function ld_csc_get_size(a) result(res) - implicit none - class(psb_ld_csc_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - - res = -1 - - if (allocated(a%ia)) then - res = size(a%ia) - end if - if (allocated(a%val)) then - if (res >= 0) then - res = min(res,size(a%val)) - else - res = size(a%val) - end if - end if - - end function ld_csc_get_size - - - - function ld_csc_get_nz_col(idx,a) result(res) - use psb_const_mod - implicit none - - class(psb_ld_csc_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then - res = a%icp(idx+1)-a%icp(idx) - end if - - end function ld_csc_get_nz_col - - - - ! == =================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - ! == =================================== - - - subroutine ld_csc_free(a) - implicit none - - class(psb_ld_csc_sparse_mat), intent(inout) :: a - - if (allocated(a%icp)) deallocate(a%icp) - if (allocated(a%ia)) deallocate(a%ia) - if (allocated(a%val)) deallocate(a%val) - call a%set_null() - call a%set_nrows(0_psb_lpk_) - call a%set_ncols(0_psb_lpk_) - - return - - end subroutine ld_csc_free - -end module psb_ld_csc_mat_mod diff --git a/base/modules/serial/psb_ld_csr_mat_mod.f90 b/base/modules/serial/psb_ld_csr_mat_mod.f90 deleted file mode 100644 index 6aec5c3d..00000000 --- a/base/modules/serial/psb_ld_csr_mat_mod.f90 +++ /dev/null @@ -1,617 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_ld_csr_mat_mod -! -! This module contains the definition of the psb_ld_csr_sparse_mat type -! which implements an actual storage format (the CSR in this case) for -! a sparse matrix as well as the related methods (those who are -! specific to the type and could not be defined higher in the -! hierarchy). We are at the bottom level of the inheritance chain. -! -! Please refere to psb_ld_base_mat_mod for a detailed description -! of the various methods, and to psb_ld_csr_impl for implementation details. -! -module psb_ld_csr_mat_mod - - use psb_d_base_mat_mod - - !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat - !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat - !! - !! psb_ld_csr_sparse_mat type and the related methods. - !! This is a very common storage type, and is the default for assembled - !! matrices in our library - type, extends(psb_ld_base_sparse_mat) :: psb_ld_csr_sparse_mat - - !> Pointers to beginning of rows in JA and VAL. - integer(psb_lpk_), allocatable :: irp(:) - !> Column indices. - integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. - real(psb_dpk_), allocatable :: val(:) - - contains - procedure, pass(a) :: is_by_rows => ld_csr_is_by_rows - procedure, pass(a) :: get_size => ld_csr_get_size - procedure, pass(a) :: get_nzeros => ld_csr_get_nzeros - procedure, nopass :: get_fmt => ld_csr_get_fmt - procedure, pass(a) :: sizeof => ld_csr_sizeof - procedure, pass(a) :: csmm => psb_ld_csr_csmm - procedure, pass(a) :: csmv => psb_ld_csr_csmv - procedure, pass(a) :: inner_cssm => psb_ld_csr_cssm - procedure, pass(a) :: inner_cssv => psb_ld_csr_cssv - procedure, pass(a) :: scals => psb_ld_csr_scals - procedure, pass(a) :: scalv => psb_ld_csr_scal - procedure, pass(a) :: maxval => psb_ld_csr_maxval - procedure, pass(a) :: spnmi => psb_ld_csr_csnmi - procedure, pass(a) :: rowsum => psb_ld_csr_rowsum - procedure, pass(a) :: arwsum => psb_ld_csr_arwsum - procedure, pass(a) :: colsum => psb_ld_csr_colsum - procedure, pass(a) :: aclsum => psb_ld_csr_aclsum - procedure, pass(a) :: reallocate_nz => psb_ld_csr_reallocate_nz - procedure, pass(a) :: allocate_mnnz => psb_ld_csr_allocate_mnnz - procedure, pass(a) :: cp_to_coo => psb_ld_cp_csr_to_coo - procedure, pass(a) :: cp_from_coo => psb_ld_cp_csr_from_coo - procedure, pass(a) :: cp_to_fmt => psb_ld_cp_csr_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_ld_cp_csr_from_fmt - procedure, pass(a) :: mv_to_coo => psb_ld_mv_csr_to_coo - procedure, pass(a) :: mv_from_coo => psb_ld_mv_csr_from_coo - procedure, pass(a) :: mv_to_fmt => psb_ld_mv_csr_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_ld_mv_csr_from_fmt - procedure, pass(a) :: csput_a => psb_ld_csr_csput_a - procedure, pass(a) :: get_diag => psb_ld_csr_get_diag - procedure, pass(a) :: csgetptn => psb_ld_csr_csgetptn - procedure, pass(a) :: csgetrow => psb_ld_csr_csgetrow - procedure, pass(a) :: get_nz_row => ld_csr_get_nz_row - procedure, pass(a) :: reinit => psb_ld_csr_reinit - procedure, pass(a) :: trim => psb_ld_csr_trim - procedure, pass(a) :: print => psb_ld_csr_print - procedure, pass(a) :: free => ld_csr_free - procedure, pass(a) :: mold => psb_ld_csr_mold - - end type psb_ld_csr_sparse_mat - - private :: ld_csr_get_nzeros, ld_csr_free, ld_csr_get_fmt, & - & ld_csr_get_size, ld_csr_sizeof, ld_csr_get_nz_row, & - & ld_csr_is_by_rows - - !> \memberof psb_ld_csr_sparse_mat - !| \see psb_base_mat_mod::psb_base_reallocate_nz - interface - subroutine psb_ld_csr_reallocate_nz(nz,a) - import - integer(psb_lpk_), intent(in) :: nz - class(psb_ld_csr_sparse_mat), intent(inout) :: a - end subroutine psb_ld_csr_reallocate_nz - end interface - - !> \memberof psb_ld_csr_sparse_mat - !| \see psb_base_mat_mod::psb_base_reinit - interface - subroutine psb_ld_csr_reinit(a,clear) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_ld_csr_reinit - end interface - - !> \memberof psb_ld_csr_sparse_mat - !| \see psb_base_mat_mod::psb_base_trim - interface - subroutine psb_ld_csr_trim(a) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - end subroutine psb_ld_csr_trim - end interface - - - !> \memberof psb_ld_csr_sparse_mat - !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ld_csr_mold(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_csr_mold - end interface - - !> \memberof psb_ld_csr_sparse_mat - !| \see psb_base_mat_mod::psb_base_allocate_mnnz - interface - subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) - import - integer(psb_lpk_), intent(in) :: m,n - class(psb_ld_csr_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_ld_csr_allocate_mnnz - end interface - - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_print - interface - subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) - import - integer(psb_ipk_), intent(in) :: iout - class(psb_ld_csr_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_ld_csr_print - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo - interface - subroutine psb_ld_cp_csr_to_coo(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csr_to_coo - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - interface - subroutine psb_ld_cp_csr_from_coo(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csr_from_coo - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_fmt - interface - subroutine psb_ld_cp_csr_to_fmt(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csr_to_fmt - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt - interface - subroutine psb_ld_cp_csr_from_fmt(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_cp_csr_from_fmt - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo - interface - subroutine psb_ld_mv_csr_to_coo(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csr_to_coo - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo - interface - subroutine psb_ld_mv_csr_from_coo(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csr_from_coo - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt - interface - subroutine psb_ld_mv_csr_to_fmt(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csr_to_fmt - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt - interface - subroutine psb_ld_mv_csr_from_fmt(a,b,info) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_mv_csr_from_fmt - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from - interface - subroutine psb_ld_csr_cp_from(a,b) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - type(psb_ld_csr_sparse_mat), intent(in) :: b - end subroutine psb_ld_csr_cp_from - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from - interface - subroutine psb_ld_csr_mv_from(a,b) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - type(psb_ld_csr_sparse_mat), intent(inout) :: b - end subroutine psb_ld_csr_mv_from - end interface - - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a - interface - subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& - & imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - end subroutine psb_ld_csr_csput_a - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_base_mat_mod::psb_base_csgetptn - interface - subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csr_csgetptn - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow - interface - subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csr_csgetrow - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csgetblk - interface - subroutine psb_ld_csr_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csr_csgetblk - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssv - interface - subroutine psb_ld_csr_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csr_cssv - end interface - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssm - interface - subroutine psb_ld_csr_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csr_cssm - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmv - interface - subroutine psb_ld_csr_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csr_csmv - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmm - interface - subroutine psb_ld_csr_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csr_csmm - end interface - - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_maxval - interface - function psb_ld_csr_maxval(a) result(res) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_csr_maxval - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csnmi - interface - function psb_ld_csr_csnmi(a) result(res) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_csr_csnmi - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_rowsum - interface - subroutine psb_ld_csr_rowsum(d,a) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csr_rowsum - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_arwsum - interface - subroutine psb_ld_csr_arwsum(d,a) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csr_arwsum - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_colsum - interface - subroutine psb_ld_csr_colsum(d,a) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csr_colsum - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_aclsum - interface - subroutine psb_ld_csr_aclsum(d,a) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_csr_aclsum - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag - interface - subroutine psb_ld_csr_get_diag(a,d,info) - import - class(psb_ld_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_csr_get_diag - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_scal - interface - subroutine psb_ld_csr_scal(d,a,info,side) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_ld_csr_scal - end interface - - !> \memberof psb_ld_csr_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_scals - interface - subroutine psb_ld_csr_scals(d,a,info) - import - class(psb_ld_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_csr_scals - end interface - - - -contains - - ! == =================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == =================================== - - - - function ld_csr_is_by_rows(a) result(res) - implicit none - class(psb_ld_csr_sparse_mat), intent(in) :: a - logical :: res - res = .true. - - end function ld_csr_is_by_rows - - - function ld_csr_sizeof(a) result(res) - implicit none - class(psb_ld_csr_sparse_mat), intent(in) :: a - integer(psb_epk_) :: res - res = 2 * psb_sizeof_lp - res = res + psb_sizeof_dp * psb_size(a%val) - res = res + psb_sizeof_lp * psb_size(a%irp) - res = res + psb_sizeof_lp * psb_size(a%ja) - - end function ld_csr_sizeof - - function ld_csr_get_fmt() result(res) - implicit none - character(len=5) :: res - res = 'CSR' - end function ld_csr_get_fmt - - function ld_csr_get_nzeros(a) result(res) - implicit none - class(psb_ld_csr_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - res = a%irp(a%get_nrows()+1)-1 - end function ld_csr_get_nzeros - - function ld_csr_get_size(a) result(res) - implicit none - class(psb_ld_csr_sparse_mat), intent(in) :: a - integer(psb_lpk_) :: res - - res = -1 - - if (allocated(a%ja)) then - res = size(a%ja) - end if - if (allocated(a%val)) then - if (res >= 0) then - res = min(res,size(a%val)) - else - res = size(a%val) - end if - end if - - end function ld_csr_get_size - - - - function ld_csr_get_nz_row(idx,a) result(res) - - implicit none - - class(psb_ld_csr_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then - res = a%irp(idx+1)-a%irp(idx) - end if - - end function ld_csr_get_nz_row - - - - ! == =================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - ! == =================================== - - subroutine ld_csr_free(a) - implicit none - - class(psb_ld_csr_sparse_mat), intent(inout) :: a - - if (allocated(a%irp)) deallocate(a%irp) - if (allocated(a%ja)) deallocate(a%ja) - if (allocated(a%val)) deallocate(a%val) - call a%set_null() - call a%set_nrows(0_psb_lpk_) - call a%set_ncols(0_psb_lpk_) - - return - - end subroutine ld_csr_free - - -end module psb_ld_csr_mat_mod diff --git a/base/modules/serial/psb_ld_mat_mod.F90 b/base/modules/serial/psb_ld_mat_mod.F90 deleted file mode 100644 index 17a12a0c..00000000 --- a/base/modules/serial/psb_ld_mat_mod.F90 +++ /dev/null @@ -1,1379 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_ld_mat_mod -! -! This module contains the definition of the psb_ld_sparse type which -! is a generic container for a sparse matrix and it is mostly meant to -! provide a mean of switching, at run-time, among different formats, -! potentially unknown at the library compile-time by adding a layer of -! indirection. This type encapsulates the psb_ld_base_sparse_mat class -! inside another class which is the one visible to the user. -! Most methods of the psb_ld_mat_mod simply call the methods of the -! encapsulated class. -! The exceptions are mainly cscnv and cp_from/cp_to; these provide -! the functionalities to have the encapsulated class change its -! type dynamically, and to extract/input an inner object. -! -! A sparse matrix has a state corresponding to its progression -! through the application life. -! In particular, computational methods can only be invoked when -! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the -! following state transition table. Associated with these states are -! the possible dynamic types of the inner matrix object. -! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method -!| ---------------------------------- -!| Null Build csall -!| Build Build csput -!| Build Assembled cscnv -!| Assembled Assembled cscnv -!| Assembled Update reinit -!| Update Update csput -!| Update Assembled cscnv -!| * unchanged reall -!| Assembled Null free -! - - -module psb_ld_mat_mod - - use psb_ld_base_mat_mod - use psb_ld_csr_mat_mod, only : psb_ld_csr_sparse_mat - use psb_ld_csc_mat_mod, only : psb_ld_csc_sparse_mat - - type :: psb_ldspmat_type - - class(psb_ld_base_sparse_mat), allocatable :: a - - contains - ! Getters - procedure, pass(a) :: get_nrows => psb_ld_get_nrows - procedure, pass(a) :: get_ncols => psb_ld_get_ncols - procedure, pass(a) :: get_nzeros => psb_ld_get_nzeros - procedure, pass(a) :: get_nz_row => psb_ld_get_nz_row - procedure, pass(a) :: get_size => psb_ld_get_size - procedure, pass(a) :: get_dupl => psb_ld_get_dupl - procedure, pass(a) :: is_null => psb_ld_is_null - procedure, pass(a) :: is_bld => psb_ld_is_bld - procedure, pass(a) :: is_upd => psb_ld_is_upd - procedure, pass(a) :: is_asb => psb_ld_is_asb - procedure, pass(a) :: is_sorted => psb_ld_is_sorted - procedure, pass(a) :: is_by_rows => psb_ld_is_by_rows - procedure, pass(a) :: is_by_cols => psb_ld_is_by_cols - procedure, pass(a) :: is_upper => psb_ld_is_upper - procedure, pass(a) :: is_lower => psb_ld_is_lower - procedure, pass(a) :: is_triangle => psb_ld_is_triangle - procedure, pass(a) :: is_unit => psb_ld_is_unit - procedure, pass(a) :: is_repeatable_updates => psb_ld_is_repeatable_updates - procedure, pass(a) :: get_fmt => psb_ld_get_fmt - procedure, pass(a) :: sizeof => psb_ld_sizeof - - ! Setters - procedure, pass(a) :: set_nrows => psb_ld_set_nrows - procedure, pass(a) :: set_ncols => psb_ld_set_ncols - procedure, pass(a) :: set_dupl => psb_ld_set_dupl - procedure, pass(a) :: set_null => psb_ld_set_null - procedure, pass(a) :: set_bld => psb_ld_set_bld - procedure, pass(a) :: set_upd => psb_ld_set_upd - procedure, pass(a) :: set_asb => psb_ld_set_asb - procedure, pass(a) :: set_sorted => psb_ld_set_sorted - procedure, pass(a) :: set_upper => psb_ld_set_upper - procedure, pass(a) :: set_lower => psb_ld_set_lower - procedure, pass(a) :: set_triangle => psb_ld_set_triangle - procedure, pass(a) :: set_unit => psb_ld_set_unit - procedure, pass(a) :: set_repeatable_updates => psb_ld_set_repeatable_updates - - ! Memory/data management - procedure, pass(a) :: csall => psb_ld_csall - procedure, pass(a) :: free => psb_ld_free - procedure, pass(a) :: trim => psb_ld_trim - procedure, pass(a) :: csput_a => psb_ld_csput_a - procedure, pass(a) :: csput_v => psb_ld_csput_v - generic, public :: csput => csput_a, csput_v - procedure, pass(a) :: csgetptn => psb_ld_csgetptn - procedure, pass(a) :: csgetrow => psb_ld_csgetrow - procedure, pass(a) :: csgetblk => psb_ld_csgetblk - generic, public :: csget => csgetptn, csgetrow, csgetblk -#if defined(IPK4) && defined(LPK8) - procedure, pass(a) :: lcsgetptn => psb_ld_lcsgetptn - procedure, pass(a) :: lcsgetrow => psb_ld_lcsgetrow - generic, public :: csget => lcsgetptn, lcsgetrow -#endif - procedure, pass(a) :: tril => psb_ld_tril - procedure, pass(a) :: triu => psb_ld_triu - procedure, pass(a) :: m_csclip => psb_ld_csclip - procedure, pass(a) :: b_csclip => psb_ld_b_csclip - generic, public :: csclip => b_csclip, m_csclip - procedure, pass(a) :: clean_zeros => psb_ld_clean_zeros - procedure, pass(a) :: reall => psb_ld_reallocate_nz - procedure, pass(a) :: get_neigh => psb_ld_get_neigh - procedure, pass(a) :: reinit => psb_ld_reinit - procedure, pass(a) :: print_i => psb_ld_sparse_print - procedure, pass(a) :: print_n => psb_ld_n_sparse_print - generic, public :: print => print_i, print_n - procedure, pass(a) :: mold => psb_ld_mold - procedure, pass(a) :: asb => psb_ld_asb - procedure, pass(a) :: transp_1mat => psb_ld_transp_1mat - procedure, pass(a) :: transp_2mat => psb_ld_transp_2mat - generic, public :: transp => transp_1mat, transp_2mat - procedure, pass(a) :: transc_1mat => psb_ld_transc_1mat - procedure, pass(a) :: transc_2mat => psb_ld_transc_2mat - generic, public :: transc => transc_1mat, transc_2mat - - ! - ! Sync: centerpiece of handling of external storage. - ! Any derived class having extra storage upon sync - ! will guarantee that both fortran/host side and - ! external side contain the same data. The base - ! version is only a placeholder. - ! - procedure, pass(a) :: sync => ld_mat_sync - procedure, pass(a) :: is_host => ld_mat_is_host - procedure, pass(a) :: is_dev => ld_mat_is_dev - procedure, pass(a) :: is_sync => ld_mat_is_sync - procedure, pass(a) :: set_host => ld_mat_set_host - procedure, pass(a) :: set_dev => ld_mat_set_dev - procedure, pass(a) :: set_sync => ld_mat_set_sync - - - ! These are specific to this level of encapsulation. - procedure, pass(a) :: mv_from_b => psb_ld_mv_from - generic, public :: mv_from => mv_from_b - procedure, pass(a) :: mv_to_b => psb_ld_mv_to - generic, public :: mv_to => mv_to_b - procedure, pass(a) :: cp_from_b => psb_ld_cp_from - generic, public :: cp_from => cp_from_b - procedure, pass(a) :: cp_to_b => psb_ld_cp_to - generic, public :: cp_to => cp_to_b - procedure, pass(a) :: clip_d_ip => psb_ld_clip_d_ip - procedure, pass(a) :: clip_d => psb_ld_clip_d - generic, public :: clip_diag => clip_d_ip, clip_d - procedure, pass(a) :: cscnv_np => psb_ld_cscnv - procedure, pass(a) :: cscnv_ip => psb_ld_cscnv_ip - procedure, pass(a) :: cscnv_base => psb_ld_cscnv_base - generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base - procedure, pass(a) :: clone => psb_ldspmat_clone - - ! Computational routines - procedure, pass(a) :: get_diag => psb_ld_get_diag - procedure, pass(a) :: maxval => psb_ld_maxval - procedure, pass(a) :: spnmi => psb_ld_csnmi - procedure, pass(a) :: spnm1 => psb_ld_csnm1 - procedure, pass(a) :: rowsum => psb_ld_rowsum - procedure, pass(a) :: arwsum => psb_ld_arwsum - procedure, pass(a) :: colsum => psb_ld_colsum - procedure, pass(a) :: aclsum => psb_ld_aclsum - procedure, pass(a) :: csmv_v => psb_ld_csmv_vect - procedure, pass(a) :: csmv => psb_ld_csmv - procedure, pass(a) :: csmm => psb_ld_csmm - generic, public :: spmm => csmm, csmv, csmv_v - procedure, pass(a) :: scals => psb_ld_scals - procedure, pass(a) :: scalv => psb_ld_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: cssv_v => psb_ld_cssv_vect - procedure, pass(a) :: cssv => psb_ld_cssv - procedure, pass(a) :: cssm => psb_ld_cssm - generic, public :: spsm => cssm, cssv, cssv_v - - end type psb_ldspmat_type - - private :: psb_ld_get_nrows, psb_ld_get_ncols, & - & psb_ld_get_nzeros, psb_ld_get_size, & - & psb_ld_get_dupl, psb_ld_is_null, psb_ld_is_bld, & - & psb_ld_is_upd, psb_ld_is_asb, psb_ld_is_sorted, & - & psb_ld_is_by_rows, psb_ld_is_by_cols, psb_ld_is_upper, & - & psb_ld_is_lower, psb_ld_is_triangle, psb_ld_get_nz_row, & - & ld_mat_sync, ld_mat_is_host, ld_mat_is_dev, & - & ld_mat_is_sync, ld_mat_set_host, ld_mat_set_dev,& - & ld_mat_set_sync - - - - class(psb_ld_base_sparse_mat), allocatable, target, & - & save, private :: psb_ld_base_mat_default - - interface psb_set_mat_default - module procedure psb_ld_set_mat_default - end interface - - interface psb_get_mat_default - module procedure psb_ld_get_mat_default - end interface - - interface psb_sizeof - module procedure psb_ld_sizeof - end interface - - - ! == =================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - ! == =================================== - - - interface - subroutine psb_ld_set_nrows(m,a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: m - end subroutine psb_ld_set_nrows - end interface - - interface - subroutine psb_ld_set_ncols(n,a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_ld_set_ncols - end interface - - interface - subroutine psb_ld_set_dupl(n,a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_ld_set_dupl - end interface - - interface - subroutine psb_ld_set_null(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_set_null - end interface - - interface - subroutine psb_ld_set_bld(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_set_bld - end interface - - interface - subroutine psb_ld_set_upd(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_set_upd - end interface - - interface - subroutine psb_ld_set_asb(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_set_asb - end interface - - interface - subroutine psb_ld_set_sorted(a,val) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_ld_set_sorted - end interface - - interface - subroutine psb_ld_set_triangle(a,val) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_ld_set_triangle - end interface - - interface - subroutine psb_ld_set_unit(a,val) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_ld_set_unit - end interface - - interface - subroutine psb_ld_set_lower(a,val) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_ld_set_lower - end interface - - interface - subroutine psb_ld_set_upper(a,val) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_ld_set_upper - end interface - - interface - subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_ldspmat_type - integer(psb_ipk_), intent(in) :: iout - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_ld_sparse_print - end interface - - interface - subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_ldspmat_type - character(len=*), intent(in) :: fname - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_ld_n_sparse_print - end interface - - interface - subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n - integer(psb_ipk_), allocatable, intent(out) :: neigh(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev - end subroutine psb_ld_get_neigh - end interface - - interface - subroutine psb_ld_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nr,nc - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: nz - end subroutine psb_ld_csall - end interface - - interface - subroutine psb_ld_reallocate_nz(nz,a) - import :: psb_ipk_, psb_ldspmat_type - integer(psb_ipk_), intent(in) :: nz - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_reallocate_nz - end interface - - interface - subroutine psb_ld_free(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_free - end interface - - interface - subroutine psb_ld_trim(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_trim - end interface - - interface - subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_ld_csput_a - end interface - - - interface - subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_ld_vect_mod, only : psb_ld_vect_type - use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - type(psb_ld_vect_type), intent(inout) :: val - type(psb_i_vect_type), intent(inout) :: ia, ja - integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_ld_csput_v - end interface - - interface - subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csgetptn - end interface - - interface - subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csgetrow - end interface - - interface - subroutine psb_ld_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csgetblk - end interface - - interface - subroutine psb_ld_tril(a,l,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ldspmat_type), optional, intent(inout) :: u - end subroutine psb_ld_tril - end interface - - interface - subroutine psb_ld_triu(a,u,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ldspmat_type), optional, intent(inout) :: l - end subroutine psb_ld_triu - end interface - - - interface - subroutine psb_ld_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_csclip - end interface - - interface - subroutine psb_ld_b_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_coo_sparse_mat - class(psb_ldspmat_type), intent(in) :: a - type(psb_ld_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_ld_b_csclip - end interface - - interface - subroutine psb_ld_mold(a,b) - import :: psb_ipk_, psb_ldspmat_type, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(inout) :: a - class(psb_ld_base_sparse_mat), allocatable, intent(out) :: b - end subroutine psb_ld_mold - end interface - - interface - subroutine psb_ld_asb(a,mold) - import :: psb_ipk_, psb_ldspmat_type, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(inout) :: a - class(psb_ld_base_sparse_mat), optional, intent(in) :: mold - end subroutine psb_ld_asb - end interface - - interface - subroutine psb_ld_transp_1mat(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_transp_1mat - end interface - - interface - subroutine psb_ld_transp_2mat(a,b) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: b - end subroutine psb_ld_transp_2mat - end interface - - interface - subroutine psb_ld_transc_1mat(a) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - end subroutine psb_ld_transc_1mat - end interface - - interface - subroutine psb_ld_transc_2mat(a,b) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: b - end subroutine psb_ld_transc_2mat - end interface - - interface - subroutine psb_ld_reinit(a,clear) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_ld_reinit - - end interface - - - ! - ! These methods are specific to the outer SPMAT_TYPE level, since - ! they tamper with the inner BASE_SPARSE_MAT object. - ! - ! - - ! - ! CSCNV: switches to a different internal derived type. - ! 3 versions: copying to target - ! copying to a base_sparse_mat object. - ! in place - ! - ! - interface - subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_ld_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_ld_cscnv - end interface - - - interface - subroutine psb_ld_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(out) :: iinfo - integer(psb_ipk_),optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_ld_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_ld_cscnv_ip - end interface - - - interface - subroutine psb_ld_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(out) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl - end subroutine psb_ld_cscnv_base - end interface - - ! - ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. - ! - interface - subroutine psb_ld_clip_d(a,b,info) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(in) :: a - class(psb_ldspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - end subroutine psb_ld_clip_d - end interface - - interface - subroutine psb_ld_clip_d_ip(a,info) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info - end subroutine psb_ld_clip_d_ip - end interface - - ! - ! These four interfaces cut through the - ! encapsulation between spmat_type and base_sparse_mat. - ! - interface - subroutine psb_ld_mv_from(a,b) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - end subroutine psb_ld_mv_from - end interface - - interface - subroutine psb_ld_cp_from(a,b) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(out) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b - end subroutine psb_ld_cp_from - end interface - - interface - subroutine psb_ld_mv_to(a,b) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - end subroutine psb_ld_mv_to - end interface - - interface - subroutine psb_ld_cp_to(a,b) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_ldspmat_type), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - end subroutine psb_ld_cp_to - end interface - - ! - ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc - subroutine psb_ldspmat_type_move(a,b,info) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - class(psb_ldspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ldspmat_type_move - end interface - - interface - subroutine psb_ldspmat_clone(a,b,info) - import :: psb_ipk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a - class(psb_ldspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ldspmat_clone - end interface - - - - - ! == =================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - ! == =================================== - - interface psb_csmm - subroutine psb_ld_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csmm - subroutine psb_ld_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csmv - subroutine psb_ld_csmv_vect(alpha,a,x,beta,y,info,trans) - use psb_ld_vect_mod, only : psb_ld_vect_type - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_ld_vect_type), intent(inout) :: x - type(psb_ld_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_csmv_vect - end interface - - interface psb_cssm - subroutine psb_ld_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_ld_cssm - subroutine psb_ld_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_ld_cssv - subroutine psb_ld_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) - use psb_ld_vect_mod, only : psb_ld_vect_type - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_ld_vect_type), intent(inout) :: x - type(psb_ld_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - type(psb_ld_vect_type), optional, intent(inout) :: d - end subroutine psb_ld_cssv_vect - end interface - - interface - function psb_ld_maxval(a) result(res) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_maxval - end interface - - interface - function psb_ld_csnmi(a) result(res) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_csnmi - end interface - - interface - function psb_ld_csnm1(a) result(res) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_csnm1 - end interface - - interface - function psb_ld_rowsum(a,info) result(d) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_ld_rowsum - end interface - - interface - function psb_ld_arwsum(a,info) result(d) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_ld_arwsum - end interface - - interface - function psb_ld_colsum(a,info) result(d) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_ld_colsum - end interface - - interface - function psb_ld_aclsum(a,info) result(d) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_ld_aclsum - end interface - - interface - function psb_ld_get_diag(a,info) result(d) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_ld_get_diag - end interface - - interface psb_scal - subroutine psb_ld_scal(d,a,info,side) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_ld_scal - subroutine psb_ld_scals(d,a,info) - import :: psb_ipk_, psb_ldspmat_type, psb_dpk_ - class(psb_ldspmat_type), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_scals - end interface - - -contains - - - - subroutine psb_ld_set_mat_default(a) - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - - if (allocated(psb_ld_base_mat_default)) then - deallocate(psb_ld_base_mat_default) - end if - allocate(psb_ld_base_mat_default, mold=a) - - end subroutine psb_ld_set_mat_default - - function psb_ld_get_mat_default(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - class(psb_ld_base_sparse_mat), pointer :: res - - res => psb_ld_get_base_mat_default() - - end function psb_ld_get_mat_default - - - function psb_ld_get_base_mat_default() result(res) - implicit none - class(psb_ld_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_ld_base_mat_default)) then - allocate(psb_ld_csr_sparse_mat :: psb_ld_base_mat_default) - end if - - res => psb_ld_base_mat_default - - end function psb_ld_get_base_mat_default - - - - - ! == =================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == =================================== - - - function psb_ld_sizeof(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_epk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_ld_sizeof - - - function psb_ld_get_fmt(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - character(len=5) :: res - - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' - end if - - end function psb_ld_get_fmt - - - function psb_ld_get_dupl(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_dupl() - else - res = psb_invalid_ - end if - end function psb_ld_get_dupl - - function psb_ld_get_nrows(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_nrows() - else - res = 0 - end if - - end function psb_ld_get_nrows - - function psb_ld_get_ncols(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_ncols() - else - res = 0 - end if - - end function psb_ld_get_ncols - - function psb_ld_is_triangle(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_triangle() - else - res = .false. - end if - - end function psb_ld_is_triangle - - function psb_ld_is_unit(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_unit() - else - res = .false. - end if - - end function psb_ld_is_unit - - function psb_ld_is_upper(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upper() - else - res = .false. - end if - - end function psb_ld_is_upper - - function psb_ld_is_lower(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = .not. a%a%is_upper() - else - res = .false. - end if - - end function psb_ld_is_lower - - function psb_ld_is_null(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_null() - else - res = .true. - end if - - end function psb_ld_is_null - - function psb_ld_is_bld(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_bld() - else - res = .false. - end if - - end function psb_ld_is_bld - - function psb_ld_is_upd(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upd() - else - res = .false. - end if - - end function psb_ld_is_upd - - function psb_ld_is_asb(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_asb() - else - res = .false. - end if - - end function psb_ld_is_asb - - function psb_ld_is_sorted(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_sorted() - else - res = .false. - end if - - end function psb_ld_is_sorted - - function psb_ld_is_by_rows(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_rows() - else - res = .false. - end if - - end function psb_ld_is_by_rows - - function psb_ld_is_by_cols(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_cols() - else - res = .false. - end if - - end function psb_ld_is_by_cols - - - ! - subroutine ld_mat_sync(a) - implicit none - class(psb_ldspmat_type), target, intent(in) :: a - - if (allocated(a%a)) call a%a%sync() - - end subroutine ld_mat_sync - - ! - subroutine ld_mat_set_host(a) - implicit none - class(psb_ldspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_host() - - end subroutine ld_mat_set_host - - - ! - subroutine ld_mat_set_dev(a) - implicit none - class(psb_ldspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_dev() - - end subroutine ld_mat_set_dev - - ! - subroutine ld_mat_set_sync(a) - implicit none - class(psb_ldspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_sync() - - end subroutine ld_mat_set_sync - - ! - function ld_mat_is_dev(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_dev() - else - res = .false. - end if - end function ld_mat_is_dev - - ! - function ld_mat_is_host(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_host() - else - res = .true. - end if - end function ld_mat_is_host - - ! - function ld_mat_is_sync(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_sync() - else - res = .true. - end if - - end function ld_mat_is_sync - - - function psb_ld_is_repeatable_updates(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_repeatable_updates() - else - res = .false. - end if - - end function psb_ld_is_repeatable_updates - - subroutine psb_ld_set_repeatable_updates(a,val) - implicit none - class(psb_ldspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - - if (allocated(a%a)) then - call a%a%set_repeatable_updates(val) - end if - - end subroutine psb_ld_set_repeatable_updates - - - function psb_ld_get_nzeros(a) result(res) - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%get_nzeros() - end if - - end function psb_ld_get_nzeros - - function psb_ld_get_size(a) result(res) - - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - - res = 0 - if (allocated(a%a)) then - res = a%a%get_size() - end if - - end function psb_ld_get_size - - - function psb_ld_get_nz_row(idx,a) result(res) - implicit none - integer(psb_ipk_), intent(in) :: idx - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - - if (allocated(a%a)) res = a%a%get_nz_row(idx) - - end function psb_ld_get_nz_row - - subroutine psb_ld_clean_zeros(a,info) - implicit none - integer(psb_ipk_), intent(out) :: info - class(psb_ldspmat_type), intent(inout) :: a - - info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) - - end subroutine psb_ld_clean_zeros - -#if defined(IPK4) && defined(LPK8) - subroutine psb_ld_lcsgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - ! Local - integer(psb_ipk_), allocatable :: lia(:), lja(:) - - info = psb_success_ - ! - ! Note: in principle we could use reallocate on assignment, - ! but GCC bug 52162 forces us to take defensive programming. - ! - if (allocated(ia)) then - call psb_realloc(size(ia),lia,info) - if (info == psb_success_) lia(:) = ia(:) - end if - if (allocated(ja)) then - call psb_realloc(size(ja),lja,info) - if (info == psb_success_) lja(:) = ja(:) - end if - call a%csget(imin,imax,nz,lia,lja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - call psb_ensure_size(size(lia),ia,info) - if (info == psb_success_) ia(:) = lia(:) - call psb_ensure_size(size(lja),ja,info) - if (info == psb_success_) ja(:) = lja(:) - - end subroutine psb_ld_lcsgetptn - - subroutine psb_ld_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - ! Local - integer(psb_ipk_), allocatable :: lia(:), lja(:) - - ! - ! Note: in principle we could use reallocate on assignment, - ! but GCC bug 52162 forces us to take defensive programming. - ! - if (allocated(ia)) then - call psb_realloc(size(ia),lia,info) - if (info == psb_success_) lia(:) = ia(:) - end if - if (allocated(ja)) then - call psb_realloc(size(ja),lja,info) - if (info == psb_success_) lja(:) = ja(:) - end if - - call a%csget(imin,imax,nz,lia,lja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - call psb_ensure_size(size(lia),ia,info) - if (info == psb_success_) ia(:) = lia(:) - call psb_ensure_size(size(lja),ja,info) - if (info == psb_success_) ja(:) = lja(:) - - end subroutine psb_ld_lcsgetrow -#endif -end module psb_ld_mat_mod diff --git a/base/modules/serial/psb_ld_serial_mod.f90 b/base/modules/serial/psb_ld_serial_mod.f90 deleted file mode 100644 index dd9b7bc7..00000000 --- a/base/modules/serial/psb_ld_serial_mod.f90 +++ /dev/null @@ -1,233 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -module psb_ld_serial_mod - use psb_const_mod - use psb_error_mod - - interface psb_amax - function psb_ldamax_s(n, x) result(val) - import :: psb_ipk_, psb_dpk_ - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_) :: val - end function psb_ldamax_s - end interface psb_amax - - interface psb_asum - function psb_ldasum_s(n, x) result(val) - import :: psb_ipk_, psb_dpk_ - integer(psb_ipk_), intent(in) :: n - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_) :: val - end function psb_ldasum_s - end interface psb_asum - - interface psb_spspmm - subroutine psb_ldspspmm(a,b,c,info) - use psb_ld_mat_mod, only : psb_ldspmat_type - import :: psb_ipk_ - implicit none - type(psb_ldspmat_type), intent(in) :: a,b - type(psb_ldspmat_type), intent(out) :: c - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ldspspmm - subroutine psb_ldcsrspspmm(a,b,c,info) - use psb_ld_mat_mod, only : psb_ld_csr_sparse_mat - import :: psb_ipk_ - implicit none - class(psb_ld_csr_sparse_mat), intent(in) :: a,b - type(psb_ld_csr_sparse_mat), intent(out) :: c - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ldcsrspspmm - subroutine psb_ldcscspspmm(a,b,c,info) - use psb_ld_mat_mod, only : psb_ld_csc_sparse_mat - import :: psb_ipk_ - implicit none - class(psb_ld_csc_sparse_mat), intent(in) :: a,b - type(psb_ld_csc_sparse_mat), intent(out) :: c - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ldcscspspmm - end interface - - interface psb_symbmm - subroutine psb_ldsymbmm(a,b,c,info) - use psb_ld_mat_mod, only : psb_ldspmat_type - import :: psb_ipk_ - implicit none - type(psb_ldspmat_type), intent(in) :: a,b - type(psb_ldspmat_type), intent(out) :: c - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ldsymbmm - subroutine psb_ldbase_symbmm(a,b,c,info) - use psb_ld_mat_mod, only : psb_ld_base_sparse_mat, psb_ld_csr_sparse_mat - import :: psb_ipk_ - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a,b - type(psb_ld_csr_sparse_mat), intent(out) :: c - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ldbase_symbmm - end interface psb_symbmm - - interface psb_numbmm - subroutine psb_ldnumbmm(a,b,c) - use psb_ld_mat_mod, only : psb_ldspmat_type - import :: psb_ipk_ - implicit none - type(psb_ldspmat_type), intent(in) :: a,b - type(psb_ldspmat_type), intent(inout) :: c - end subroutine psb_ldnumbmm - subroutine psb_ldbase_numbmm(a,b,c) - use psb_ld_mat_mod, only : psb_ld_base_sparse_mat, psb_ld_csr_sparse_mat - import :: psb_ipk_ - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a,b - type(psb_ld_csr_sparse_mat), intent(inout) :: c - end subroutine psb_ldbase_numbmm - end interface psb_numbmm - - interface psb_rwextd - subroutine psb_ldrwextd(nr,a,info,b,rowscale) - use psb_ld_mat_mod, only : psb_ldspmat_type - import :: psb_ipk_ - implicit none - integer(psb_ipk_), intent(in) :: nr - type(psb_ldspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info - type(psb_ldspmat_type), intent(in), optional :: b - logical,intent(in), optional :: rowscale - end subroutine psb_ldrwextd - subroutine psb_ldbase_rwextd(nr,a,info,b,rowscale) - use psb_ld_mat_mod, only : psb_ld_base_sparse_mat - import :: psb_ipk_ - implicit none - integer(psb_ipk_), intent(in) :: nr - class(psb_ld_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info - class(psb_ld_base_sparse_mat), intent(in), optional :: b - logical,intent(in), optional :: rowscale - end subroutine psb_ldbase_rwextd - end interface psb_rwextd - - - interface psb_geprt - subroutine psb_ldgeprtn2(fname,a,head) - use psb_const_mod, only : psb_dpk_, psb_ipk_ - character(len=*), intent(in) :: fname - real(psb_dpk_), intent(in) :: a(:,:) - character(len=*), optional :: head - end subroutine psb_ldgeprtn2 - subroutine psb_ldgeprtn1(fname,a,head) - use psb_const_mod, only : psb_dpk_, psb_ipk_ - character(len=*), intent(in) :: fname - real(psb_dpk_), intent(in) :: a(:) - character(len=*), optional :: head - end subroutine psb_ldgeprtn1 - subroutine psb_ldgeprt2(iout,a,head) - use psb_const_mod, only : psb_dpk_, psb_ipk_ - integer(psb_ipk_), intent(in) :: iout - real(psb_dpk_), intent(in) :: a(:,:) - character(len=*), optional :: head - end subroutine psb_ldgeprt2 - subroutine psb_ldgeprt1(iout,a,head) - use psb_const_mod, only : psb_dpk_, psb_ipk_ - integer(psb_ipk_), intent(in) :: iout - real(psb_dpk_), intent(in) :: a(:) - character(len=*), optional :: head - end subroutine psb_ldgeprt1 - end interface psb_geprt - - interface psb_csprt - module procedure psb_ldcsprt, psb_ldcsprtn - end interface psb_csprt - - interface psb_spdot_srtd - function psb_ld_spdot_srtd(nv1,iv1,v1,nv2,iv2,v2) result(dot) - use psb_const_mod, only : psb_ipk_, psb_dpk_ - integer(psb_ipk_), intent(in) :: nv1,nv2 - integer(psb_ipk_), intent(in) :: iv1(*), iv2(*) - real(psb_dpk_), intent(in) :: v1(*),v2(*) - real(psb_dpk_) :: dot - end function psb_ld_spdot_srtd - end interface psb_spdot_srtd - - - interface psb_spge_dot - function psb_ld_spge_dot(nv1,iv1,v1,v2) result(dot) - use psb_const_mod, only : psb_ipk_, psb_dpk_ - integer(psb_ipk_), intent(in) :: nv1 - integer(psb_ipk_), intent(in) :: iv1(*) - real(psb_dpk_), intent(in) :: v1(*),v2(*) - real(psb_dpk_) :: dot - end function psb_ld_spge_dot - end interface psb_spge_dot - - - interface psb_aspxpby - subroutine psb_ld_aspxpby(alpha, nx, ix, x, beta, y, info) - use psb_const_mod, only : psb_ipk_, psb_dpk_ - integer(psb_ipk_), intent(in) :: nx - integer(psb_ipk_), intent(in) :: ix(:) - real(psb_dpk_), intent (in) :: x(:) - real(psb_dpk_), intent (inout) :: y(:) - real(psb_dpk_), intent (in) :: alpha, beta - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_aspxpby - end interface psb_aspxpby - -contains - - subroutine psb_ldcsprt(iout,a,iv,head,ivr,ivc) - use psb_ld_mat_mod, only : psb_ldspmat_type - integer(psb_ipk_), intent(in) :: iout - type(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:) - - call a%print(iout,iv,head,ivr,ivc) - - end subroutine psb_ldcsprt - - subroutine psb_ldcsprtn(fname,a,iv,head,ivr,ivc) - use psb_ld_mat_mod, only : psb_ldspmat_type - character(len=*), intent(in) :: fname - type(psb_ldspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:) - - call a%print(fname,iv,head,ivr,ivc) - - end subroutine psb_ldcsprtn - -end module psb_ld_serial_mod - diff --git a/base/serial/impl/psb_c_lbase_mat_impl.F90 b/base/serial/impl/psb_c_lbase_mat_impl.F90 deleted file mode 100644 index 2457f710..00000000 --- a/base/serial/impl/psb_c_lbase_mat_impl.F90 +++ /dev/null @@ -1,2320 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - -subroutine psb_lc_base_cp_to_coo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_cp_to_coo - -subroutine psb_lc_base_cp_from_coo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_lc_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_cp_from_coo - - -subroutine psb_lc_base_cp_to_fmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lc_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_lc_coo_sparse_mat) - call a%cp_to_coo(b,info) - class default - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_cp_to_fmt - -subroutine psb_lc_base_cp_from_fmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_lc_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_lc_coo_sparse_mat) - call a%cp_from_coo(b,info) - class default - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_cp_from_fmt - - -subroutine psb_lc_base_mv_to_coo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_mv_to_coo - -subroutine psb_lc_base_mv_from_coo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - -8 -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_mv_from_coo - - -subroutine psb_lc_base_mv_to_fmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_lc_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_lc_coo_sparse_mat) - call a%mv_to_coo(b,info) - class default - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_lc_base_mv_to_fmt - -subroutine psb_lc_base_mv_from_fmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_lc_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_lc_coo_sparse_mat) - call a%mv_from_coo(b,info) - class default - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_lc_base_mv_from_fmt - -subroutine psb_lc_base_clean_zeros(a, info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clean_zeros - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - ! - type(psb_lc_coo_sparse_mat) :: tmpcoo - - call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) - if (info == 0) call a%mv_from_coo(tmpcoo,info) - -end subroutine psb_lc_base_clean_zeros - - -subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_a - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_csput_a - -subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_v - use psb_c_base_vect_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_c_base_vect_type), intent(inout) :: val - class(psb_l_base_vect_type), intent(inout) :: ia, ja - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - integer(psb_lpk_) :: nzin, nzout - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput_v' - integer :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - if (a%is_dev()) call a%sync() - if (val%is_dev()) call val%sync() - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) - else - info = psb_err_invalid_mat_state_ - endif - if (info /= 0) then - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_csput_v - -subroutine psb_lc_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetrow - implicit none - - class(psb_lc_base_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_csgetrow - - - -! -! Here we have the base implementation of getblk and clip: -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetblk - implicit none - - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout - character(len=20) :: name='csget' - integer(psb_lpk_) :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - if (present(rscale)) then - rscale_=rscale - else - rscale_=.false. - end if - if (present(cscale)) then - cscale_=cscale - else - cscale_=.false. - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if (append_.and.(rscale_.or.cscale_)) then - write(psb_err_unit,*) & - & 'lc_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' - end if - - if (rscale_) then - call b%set_nrows(imax-imin+1) - else - call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) - end if - - if (cscale_) then - call b%set_ncols(jmax_-jmin_+1) - else - call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) - end if - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_csgetblk - - -subroutine psb_lc_base_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csclip - implicit none - - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lc_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_csclip - - -! -! Here we have the base implementation of tril and triu -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_lc_base_tril(a,l,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_tril - implicit none - - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lc_coo_sparse_mat), intent(out) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_lc_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - complex(psb_spk_), allocatable :: val(:) - character(len=20) :: name='tril' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call l%allocate(mb,nb,nz) - - if (present(u)) then - nzlin = l%get_nzeros() ! At this point it should be 0 - call u%allocate(mb,nb,nz) - nzuin = u%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i<=diag_) then - nzlin = nzlin + 1 - l%ia(nzlin) = ia(k) - l%ja(nzlin) = ja(k) - l%val(nzlin) = val(k) - else - nzuin = nzuin + 1 - u%ia(nzuin) = ia(k) - u%ja(nzuin) = ja(k) - u%val(nzuin) = val(k) - end if - end do - end do - - call l%set_nzeros(nzlin) - call u%set_nzeros(nzuin) - call u%fix(info) - nzout = u%get_nzeros() - if (rscale_) & - & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_lower(.false.) - end if - else - nzin = l%get_nzeros() ! At this point it should be 0 - do i=imin_,imax_ - k = min(jmax_,i+diag_) - call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& - & jmin=jmin_, jmax=k, append=.true., & - & nzin=nzin) - if (info /= psb_success_) goto 9999 - call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout - end do - end if - call l%fix(info) - nzout = l%get_nzeros() - if (rscale_) & - & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then - call l%set_triangle(.true.) - call l%set_lower(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_tril - -subroutine psb_lc_base_triu(a,u,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_triu - implicit none - - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lc_coo_sparse_mat), intent(out) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_lc_coo_sparse_mat), optional, intent(out) :: l - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - complex(psb_spk_), allocatable :: val(:) - character(len=20) :: name='triu' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call u%allocate(mb,nb,nz) - - if (present(l)) then - nzuin = u%get_nzeros() ! At this point it should be 0 - call l%allocate(mb,nb,nz) - nzlin = l%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i= 0).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_upper(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_triu - - - -subroutine psb_lc_base_clone(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clone - use psb_error_mod - implicit none - - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_lc_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b, stat=info) - end if - if (info /= 0) then - info = psb_err_alloc_dealloc_ - return - end if - - ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. - allocate(b,mold=a,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - -end subroutine psb_lc_base_clone - -subroutine psb_lc_base_make_nonunit(a) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_make_nonunit - use psb_error_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - type(psb_lc_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i, j, m, n, nz, mnm - - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) - if (info /= 0) return - m = tmp%get_nrows() - n = tmp%get_ncols() - mnm = min(m,n) - nz = tmp%get_nzeros() - call tmp%reallocate(nz+mnm) - do i=1, mnm - tmp%val(nz+i) = cone - tmp%ia(nz+i) = i - tmp%ja(nz+i) = i - end do - call tmp%set_nzeros(nz+mnm) - call tmp%set_unit(.false.) - call tmp%fix(info) - if (info /= 0) & - & call a%mv_from_coo(tmp,info) - end if - -end subroutine psb_lc_base_make_nonunit - -subroutine psb_lc_base_mold(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mold - use psb_error_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='base_mold' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_mold - -subroutine psb_lc_base_transp_2mat(a,b) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_2mat - use psb_error_mod - implicit none - - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_lc_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lc_base_transp' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_lc_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_transp_2mat - -subroutine psb_lc_base_transc_2mat(a,b) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_2mat - implicit none - - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_lc_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lc_base_transc' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_lc_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return -end subroutine psb_lc_base_transc_2mat - -subroutine psb_lc_base_transp_1mat(a) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_1mat - use psb_error_mod - implicit none - - class(psb_lc_base_sparse_mat), intent(inout) :: a - - type(psb_lc_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lc_base_transp' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_transp_1mat - -subroutine psb_lc_base_transc_1mat(a) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_1mat - implicit none - - class(psb_lc_base_sparse_mat), intent(inout) :: a - - type(psb_lc_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lc_base_transc' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_transc_1mat - - -! == ================================== -! -! -! -! Computational routines -! -! -! -! -! -! -! == ================================== - -subroutine psb_lc_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csmm - use psb_error_mod - - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_base_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_csmm - - -subroutine psb_lc_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csmv - use psb_error_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_base_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - - -end subroutine psb_lc_base_csmv - - -subroutine psb_lc_base_inner_cssm(alpha,a,x,beta,y,info,trans) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_inner_cssm - use psb_error_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_base_inner_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_inner_cssm - - -subroutine psb_lc_base_inner_cssv(alpha,a,x,beta,y,info,trans) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_inner_cssv - use psb_error_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_base_inner_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_inner_cssv - - -subroutine psb_lc_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cssm - use psb_error_mod - use psb_string_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - - complex(psb_spk_), allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='lc_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(cone,x,czero,tmp,info,trans) - - if (info == psb_success_)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == psb_success_) then - inar = nar - inc = nc - call psb_geaxpby(inar,inc,alpha,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_cssm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_cssm - - -subroutine psb_lc_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cssv - use psb_error_mod - use psb_string_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - - complex(psb_spk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='lc_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == czero) then - call a%inner_spsm(alpha,x,czero,y,info,trans) - if (info == psb_success_) call inner_vscal1(nar,d,y) - else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,czero,tmp,info,trans) - - if (info == psb_success_) call inner_vscal1(nar,d,tmp) - if (info == psb_success_) then - inar = nar - call psb_geaxpby(inar,cone,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return -contains - subroutine inner_vscal(n,d,x,y) - implicit none - integer(psb_lpk_), intent(in) :: n - complex(psb_spk_), intent(in) :: d(*),x(*) - complex(psb_spk_), intent(out) :: y(*) - integer(psb_lpk_) :: i - - do i=1,n - y(i) = d(i)*x(i) - end do - end subroutine inner_vscal - - - subroutine inner_vscal1(n,d,x) - implicit none - integer(psb_lpk_), intent(in) :: n - complex(psb_spk_), intent(in) :: d(*) - complex(psb_spk_), intent(inout) :: x(*) - integer(psb_lpk_) :: i - - do i=1,n - x(i) = d(i)*x(i) - end do - end subroutine inner_vscal1 - -end subroutine psb_lc_base_cssv - - -subroutine psb_lc_base_scals(d,a,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scals - use psb_error_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_scals' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_scals - - - -subroutine psb_lc_base_scal(d,a,info,side) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scal - use psb_error_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_scal' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_scal - - - -function psb_lc_base_maxval(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_maxval - - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='maxval' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - res = szero - ! 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()) - - call psb_error_handler(err_act) - -end function psb_lc_base_maxval - - -function psb_lc_base_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnmi - - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnmi' - real(psb_spk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = szero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%arwsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_lc_base_csnmi - -function psb_lc_base_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnm1 - - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnm1' - real(psb_spk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = szero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%aclsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_lc_base_csnm1 - -subroutine psb_lc_base_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_rowsum - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_rowsum - -subroutine psb_lc_base_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_arwsum - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='arwsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_arwsum - -subroutine psb_lc_base_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_colsum - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_colsum - -subroutine psb_lc_base_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_aclsum - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_aclsum - - -subroutine psb_lc_base_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_get_diag - - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lc_base_get_diag - - -! == ================================== -! -! -! -! Computational routines for lc_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! -! -! -! -! == ================================== - - - -subroutine psb_lc_base_vect_mv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_vect_mv - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - ! For the time being we just throw everything back - ! onto the normal routines. - call x%sync() - call y%sync() - call a%spmm(alpha,x%v,beta,y%v,info,trans) - call y%set_host() -end subroutine psb_lc_base_vect_mv - -subroutine psb_lc_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_vect_cssv - use psb_c_base_vect_mod - use psb_error_mod - use psb_string_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - class(psb_c_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_c_base_vect_type), intent(inout),optional :: d - - complex(psb_spk_), allocatable :: tmp(:) - class(psb_c_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='lc_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (x%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (y%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call x%sync() - call y%sync() - if (present(d)) then - call d%sync() - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (d%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(cone,d%v(1:nac),x,czero,info) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (d%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == czero) then - call a%inner_spsm(alpha,x,czero,y,info,trans) - if (info == psb_success_) call y%mlt(d%v(1:nar),info) - - else - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,czero,tmpv,info,trans) - - if (info == psb_success_) call tmpv%mlt(d%v(1:nar),info) - if (info == psb_success_) then - inar = nar - call y%axpby(inar,cone,tmpv,beta,info) - end if - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_vect_cssv - - -subroutine psb_lc_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_inner_vect_sv - use psb_error_mod - use psb_string_mod - use psb_c_base_vect_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - class(psb_c_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_base_inner_vect_sv' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_inner_vect_sv - - - - -subroutine psb_lc_base_cp_to_icoo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_cp_to_icoo - -subroutine psb_lc_base_cp_from_icoo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call tmp%cp_from_icoo(b,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_cp_from_icoo - - -subroutine psb_lc_base_cp_to_ifmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_c_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_c_coo_sparse_mat) - call a%cp_to_icoo(b,info) - class default - call a%cp_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_cp_to_ifmt - -subroutine psb_lc_base_cp_from_ifmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_c_coo_sparse_mat) - call a%cp_from_icoo(b,info) - class default - call b%cp_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_cp_from_ifmt - - -subroutine psb_lc_base_mv_to_icoo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_icoo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_mv_to_icoo - -subroutine psb_lc_base_mv_from_icoo(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_base_mv_from_icoo - - -subroutine psb_lc_base_mv_to_ifmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_c_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_c_coo_sparse_mat) - call a%mv_to_icoo(b,info) - class default - call a%mv_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_lc_base_mv_to_ifmt - -subroutine psb_lc_base_mv_from_ifmt(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lc_base_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_lc_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_c_coo_sparse_mat) - call a%mv_from_icoo(b,info) - class default - call b%mv_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_lc_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_c_lcoo_impl.f90 b/base/serial/impl/psb_c_lcoo_impl.f90 deleted file mode 100644 index cbf1a6c7..00000000 --- a/base/serial/impl/psb_c_lcoo_impl.f90 +++ /dev/null @@ -1,4127 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! - -subroutine psb_lc_coo_get_diag(a,d,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_diag - use psb_error_mod - use psb_const_mod - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - if (a%is_unit()) then - d(1:mnm) = cone - else - d(1:mnm) = czero - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_get_diag - - -subroutine psb_lc_coo_scal(d,a,info,side) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scal - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - character :: side_ - logical :: left - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - side_ = 'L' - if (present(side)) then - side_ = psb_toupper(side) - end if - - left = (side_ == 'L') - - if (left) then - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - else - m = a%get_ncols() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ja(i) - a%val(i) = a%val(i) * d(j) - enddo - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_scal - - -subroutine psb_lc_coo_scals(d,a,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scals - use psb_error_mod - use psb_const_mod - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_scals - - -subroutine psb_lc_coo_reallocate_nz(nz,a) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reallocate_nz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: nz - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='lc_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_reallocate_nz - -subroutine psb_lc_coo_mold(a,b,info) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mold - use psb_error_mod - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='coo_mold' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b,stat=info) - end if - if (info == 0) allocate(psb_lc_coo_sparse_mat :: b, stat=info) - - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info, name) - goto 9999 - end if - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_mold - -subroutine psb_lc_coo_reinit(a,clear) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reinit - use psb_error_mod - implicit none - - class(psb_lc_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = czero - call a%set_host() - call a%set_upd() - else - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_reinit - - - -subroutine psb_lc_coo_trim(a) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_trim - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - nz = a%get_nzeros() - if (info == psb_success_) call psb_realloc(nz,a%ia,info) - if (info == psb_success_) call psb_realloc(nz,a%ja,info) - if (info == psb_success_) call psb_realloc(nz,a%val,info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_trim - -subroutine psb_lc_coo_clean_zeros(a, info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_zeros - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info - ! - integer(psb_lpk_) :: i,j,k, nzin - - info = 0 - nzin = a%get_nzeros() - j = 0 - do i=1, nzin - if (a%val(i) /= czero) then - j = j + 1 - a%val(j) = a%val(i) - a%ia(j) = a%ia(i) - a%ja(j) = a%ja(i) - end if - end do - call a%set_nzeros(j) - call a%trim() -end subroutine psb_lc_coo_clean_zeros - - - -subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_allocate_mnnz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: m,n - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (m < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/ione,izero/)) - goto 9999 - endif - if (n < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) - goto 9999 - endif - if (present(nz)) then - nz_ = max(nz,ione) - else - nz_ = max(7*m,7*n,ione) - end if - if (nz_ < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) - goto 9999 - endif - if (info == psb_success_) call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(lzero) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - ! An empty matrix is sorted! - call a%set_sorted(.true.) - call a%set_host() - end if - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_allocate_mnnz - - - -subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_print - use psb_string_mod - implicit none - - integer(psb_ipk_), intent(in) :: iout - class(psb_lc_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_coo_print' - logical, parameter :: debug=.false. - - character(len=*), parameter :: datatype='complex' - character(len=80) :: frmtv - integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz - - write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - - if (a%is_dev()) call a%sync() - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - if (present(iv)) nmx = max(nmx,maxval(abs(iv))) - if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) - if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) - ni = floor(log10(1.0*nmx)) + 1 - - if (datatype=='real') then - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - else - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - end if - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - -end subroutine psb_lc_coo_print - - - - -function psb_lc_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_nz_row - implicit none - - class(psb_lc_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_) :: res - integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k - integer(psb_ipk_) :: inza - - if (a%is_dev()) call a%sync() - res = 0 - nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. - inza = nza - ip = psb_bsrch(idx,inza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - -end function psb_lc_coo_get_nz_row - -subroutine psb_lc_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cssm - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: tmp(:,:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_base_csmm' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nc = min(size(x,2) , size(y,2)) - nnz = a%get_nzeros() - - if (alpha == czero) then - if (beta == czero) then - do i = 1, m - y(i,1:nc) = czero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - end if - - if (beta == czero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),y,size(y,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*y(i,1:nc) - end do - else - allocate(tmp(m,nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),tmp,size(tmp,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) - end do - end if - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='inner_coosm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - - -contains - - subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) - complex(psb_spk_), intent(in) :: val(*), x(ldx,*) - complex(psb_spk_), intent(out) :: y(ldy,*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc - complex(psb_spk_), allocatable :: acc(:) - - info = psb_success_ - allocate(acc(nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - return - end if - - - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = czero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc(1:nc) = czero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j + 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = czero - do - if (j < 1) exit - if (ia(j) < i) exit - acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) - j = j - 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc(1:nc) = czero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j - 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / conjg(val(j)) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / conjg(val(j)) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - end if - end subroutine inner_coosm - -end subroutine psb_lc_coo_cssm - - - -subroutine psb_lc_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cssv - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: tmp(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_coo_cssv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (alpha == czero) then - if (beta == czero) then - do i = 1, m - y(i) = czero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - end if - - if (beta == czero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,y,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*y(i) - end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,tmp,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*tmp(i) + beta*y(i) - end do - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nz,ia(*),ja(*) - complex(psb_spk_), intent(in) :: val(*), x(*) - complex(psb_spk_), intent(out) :: y(*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc, nnz - complex(psb_spk_) :: acc - - info = psb_success_ - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc = czero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - y(i) = x(i) - acc - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc = czero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j + 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = czero - do - if (j < 1) exit - if (ia(j) < i) exit - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - y(i) = x(i) - acc - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc = czero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j - 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /conjg(val(j)) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /conjg(val(j)) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j + 1 - end do - end do - end if - end if - end if - end if - - end subroutine inner_coosv - - -end subroutine psb_lc_coo_cssv - -subroutine psb_lc_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csmv - implicit none - - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_spk_) :: acc - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_coo_csmv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - if (alpha == czero) then - if (beta == czero) then - do i = 1, m - y(i) = czero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - else - if (a%is_unit()) then - if (beta == czero) then - do i = 1, min(m,n) - y(i) = alpha*x(i) - enddo - do i = min(m,n)+1, m - y(i) = czero - enddo - else - do i = 1, min(m,n) - y(i) = beta*y(i) + alpha*x(i) - end do - do i = min(m,n)+1, m - y(i) = beta*y(i) - enddo - endif - else - if (beta == czero) then - do i = 1, m - y(i) = czero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - - endif - - end if - - if ((.not.tra).and.(.not.ctra)) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = czero - do - if (i>nnz) then - y(ir) = y(ir) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir) = y(ir) + alpha * acc - ir = a%ia(i) - acc = czero - endif - acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == cone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + a%val(i)*x(jc) - enddo - - else if (alpha == -cone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - a%val(i)*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*a%val(i)*x(jc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == cone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + conjg(a%val(i))*x(jc) - enddo - - else if (alpha == -cone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - conjg(a%val(i))*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*conjg(a%val(i))*x(jc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_csmv - - -subroutine psb_lc_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csmm - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_), allocatable :: acc(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_coo_csmm_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - nc = min(size(x,2), size(y,2)) - allocate(acc(nc),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - - if (alpha == czero) then - if (beta == czero) then - do i = 1, m - y(i,1:nc) = czero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - else - if (a%is_unit()) then - if (beta == czero) then - do i = 1, min(m,n) - y(i,1:nc) = alpha*x(i,1:nc) - enddo - do i = min(m,n)+1, m - y(i,1:nc) = czero - enddo - else - do i = 1, min(m,n) - y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) - end do - do i = min(m,n)+1, m - y(i,1:nc) = beta*y(i,1:nc) - enddo - endif - else - if (beta == czero) then - do i = 1, m - y(i,1:nc) = czero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - - endif - - end if - - if (.not.tra) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = czero - do - if (i>nnz) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) - acc = czero - endif - acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == cone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) - enddo - - else if (alpha == -cone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == cone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + conjg(a%val(i))*x(jc,1:nc) - enddo - - else if (alpha == -cone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - conjg(a%val(i))*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*conjg(a%val(i))*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_csmm - -function psb_lc_coo_maxval(a) result(res) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_maxval - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - character(len=20) :: name='lc_coo_maxval' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - res = sone - else - res = szero - end if - nnz = a%get_nzeros() - if (allocated(a%val)) then - nnz = min(nnz,size(a%val)) - res = maxval(abs(a%val(1:nnz))) - end if - -end function psb_lc_coo_maxval - -function psb_lc_coo_csnmi(a) result(res) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnmi - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra, is_unit - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='lc_coo_csnmi' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = szero - nnz = a%get_nzeros() - is_unit = a%is_unit() - if (a%is_by_rows()) then - i = 1 - j = i - res = szero - do while (i<=nnz) - do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) - j = j+1 - enddo - if (is_unit) then - acc = sone - else - acc = szero - end if - 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 - if (is_unit) then - vt = sone - else - vt = szero - end if - do j=1, nnz - i = a%ia(j) - vt(i) = vt(i) + abs(a%val(j)) - end do - res = maxval(vt(1:m)) - deallocate(vt,stat=info) - end if - -end function psb_lc_coo_csnmi - - -function psb_lc_coo_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnm1 - - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='lc_coo_csnm1' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = szero - nnz = a%get_nzeros() - n = a%get_ncols() - allocate(vt(n),stat=info) - if (info /= 0) return - if (a%is_unit()) then - vt = sone - else - vt = szero - end if - 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) - - return - -end function psb_lc_coo_csnm1 - -subroutine psb_lc_coo_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_rowsum - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = cone - else - d = czero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_rowsum - -subroutine psb_lc_coo_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_arwsum - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = sone - else - d = szero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_arwsum - -subroutine psb_lc_coo_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_colsum - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - if (a%is_unit()) then - d = cone - else - d = czero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_colsum - -subroutine psb_lc_coo_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_aclsum - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - - if (a%is_unit()) then - d = sone - else - d = szero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_aclsum - - - -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - - - -subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csgetptn - implicit none - - class(psb_lc_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = iren(a%ia(i)) - ja(nzin_) = iren(a%ja(i)) - end if - enddo - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = a%ia(i) - ja(nzin_) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - end if - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - end if - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - nzin_=nzin_+k - end if - nz = k - end if - - end subroutine coo_getptn - -end subroutine psb_lc_coo_csgetptn - - -! -! NZ is the number of non-zeros on output. -! The output is guaranteed to be sorted -! -subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csgetrow - implicit none - - class(psb_lc_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = iren(a%ia(i)) - ja(nzin_+nz) = iren(a%ja(i)) - end if - enddo - call psb_lc_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = a%ia(i) - ja(nzin_+nz) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - end if - call psb_lc_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - end if - - end subroutine coo_getrow - -end subroutine psb_lc_coo_csgetrow - - -subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csput_a - implicit none - - class(psb_lc_coo_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lc_coo_csput_a_impl' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: nza, i,j,k, nzl, isza - integer(psb_ipk_) :: debug_level, debug_unit - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (nz < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) - goto 9999 - end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) - goto 9999 - end if - - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) - goto 9999 - end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) - goto 9999 - end if - - if (nz == 0) return - - - nza = a%get_nzeros() - isza = a%get_size() - if (a%is_bld()) then - ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then - call a%reallocate(max(nza+nz,int(1.5*isza))) - endif - isza = a%get_size() - if (isza < (nza+nz)) then - info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 - end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& - & imin,imax,jmin,jmax,info,gtl) - call a%set_nzeros(nza) - call a%set_sorted(.false.) - - - else if (a%is_upd()) then - - if (a%is_dev()) call a%sync() - - call lc_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - if (info < 0) then - info = psb_err_internal_error_ - else if (info > 0) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' - info = psb_success_ - end if - else - ! State is wrong. - info = psb_err_invalid_mat_state_ - end if - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl) - implicit none - - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) - complex(psb_spk_), intent(in) :: val(:) - complex(psb_spk_), intent(inout) :: aspk(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic,ng - - info = psb_success_ - if (present(gtl)) then - ng = size(gtl) - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - - - subroutine lc_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - implicit none - - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nnz,dupl,ng, nr - integer(psb_ipk_) :: debug_level, debug_unit, innz, nc - character(len=20) :: name='lc_coo_srch_upd' - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - dupl = a%get_dupl() - - if (.not.a%is_sorted()) then - info = -4 - return - end if - - ilr = -1 - ilc = -1 - nnz = a%get_nzeros() - nr = a%get_nrows() - innz = nnz - - if (present(gtl)) then - ng = size(gtl) - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= nr)) then - ic = gtl(ic) - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - endif - else - info = max(info,1) - end if - end do - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - else - info = max(info,1) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - end if - - end subroutine lc_coo_srch_upd - -end subroutine psb_lc_coo_csput_a - - -subroutine psb_lc_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_coo - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_cp_coo_to_coo - -subroutine psb_lc_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_coo - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - class(psb_lc_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_cp_coo_from_coo - - -subroutine psb_lc_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_fmt - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - class(psb_lc_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_cp_coo_to_fmt - -subroutine psb_lc_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_fmt - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - class(psb_lc_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_cp_coo_from_fmt - - -subroutine psb_lc_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_coo - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - call b%set_nzeros(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call b%set_host() - call a%free() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_mv_coo_to_coo - -subroutine psb_lc_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_coo - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - class(psb_lc_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - call a%set_nzeros(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_mv_coo_from_coo - - -subroutine psb_lc_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_fmt - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - class(psb_lc_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_mv_coo_to_fmt - -subroutine psb_lc_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_fmt - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - class(psb_lc_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_mv_coo_from_fmt - -subroutine psb_lc_coo_cp_from(a,b) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cp_from - implicit none - - class(psb_lc_coo_sparse_mat), intent(inout) :: a - type(psb_lc_coo_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%cp_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_cp_from - -subroutine psb_lc_coo_mv_from(a,b) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mv_from - implicit none - - class(psb_lc_coo_sparse_mat), intent(inout) :: a - type(psb_lc_coo_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_coo_mv_from - - - -subroutine psb_lc_fix_coo(a,info,idir) - use psb_const_mod - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo - implicit none - - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - integer(psb_lpk_), allocatable :: iaux(:) - !locals - integer(psb_lpk_) :: nza, nzl,iret, nra, nca - integer(psb_lpk_) :: i,j, irw, icl - integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ - character(len=20) :: name = 'psb_fixcoo' - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia),size(a%ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - if (a%is_dev()) call a%sync() - - nra = a%get_nrows() - nca = a%get_ncols() - nza = a%get_nzeros() - if (nza >= 2) then - dupl_ = a%get_dupl() - call psb_lc_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= psb_success_) goto 9999 - else - i = nza - end if - call a%set_sort_status(idir_) - call a%set_nzeros(i) - call a%set_asb() - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_fix_coo - - - -subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo_inner - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod - implicit none - - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_lpk_), intent(inout) :: ia(:), ja(:) - complex(psb_spk_), intent(inout) :: val(:) - integer(psb_lpk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - !locals - integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) - complex(psb_spk_), allocatable :: vs(:) - integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin - integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(ia),size(ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - - - if (nzin < 2) then - call psb_erractionrestore(err_act) - return - end if - - dupl_ = dupl - - - - allocate(iaux(max(nr,nc,nzin)+2),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) - use_buffers = (info == 0) - - select case(idir_) - - case(psb_row_major_) - ! Row major order - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then - iaux(:) = 0 - iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ia(i)) = iaux(ia(i)) + 1 - srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) - end do - else - use_buffers=.false. - end if - end if - ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major - ! we can do it row-by-row here. - k = 0 - i = 1 - do j=1, nr - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ja(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already row-major - ! we have to sort all - - ip = iaux(1) - iaux(1) = 0 - do i=2, nr - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nr+1) = ip - - do i=1,nzin - irw = ia(i) - ip = iaux(irw) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(irw) = ip - end do - k = 0 - i = 1 - do j=1, nr - - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,jas(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - ! - ! If we did not have enough memory for buffers, - ! let's try in place. - ! - inzin = nzin - call psi_msort_up(inzin,ia(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - - do while ((ia(j) == ia(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ja(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - endif - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - - case(psb_col_major_) - - if (use_buffers) then - iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then - iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ja(i)) = iaux(ja(i)) + 1 - srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do - else - use_buffers=.false. - end if - end if - !use_buffers=use_buffers.and.srt_inp - ! Check again use_buffers. - if (use_buffers) then - - if (srt_inp) then - ! If input was already col-major - ! we can do it col-by-col here. - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already col-major - ! we have to sort all - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - inzin = nzin - call psi_msort_up(inzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 - end select - - nzout = i - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_fix_coo_inner - - -subroutine psb_lc_cp_coo_to_icoo(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_icoo - implicit none - class(psb_lc_coo_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_base_sparse_mat = a%psb_lbase_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_cp_coo_to_icoo - -subroutine psb_lc_cp_coo_from_icoo(a,b,info) - use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_icoo - implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lbase_sparse_mat = b%psb_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lc_cp_coo_from_icoo - diff --git a/base/serial/impl/psb_d_lbase_mat_impl.F90 b/base/serial/impl/psb_d_lbase_mat_impl.F90 deleted file mode 100644 index a592598c..00000000 --- a/base/serial/impl/psb_d_lbase_mat_impl.F90 +++ /dev/null @@ -1,2320 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - -subroutine psb_ld_base_cp_to_coo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_cp_to_coo - -subroutine psb_ld_base_cp_from_coo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_cp_from_coo - - -subroutine psb_ld_base_cp_to_fmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_ld_coo_sparse_mat) - call a%cp_to_coo(b,info) - class default - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_cp_to_fmt - -subroutine psb_ld_base_cp_from_fmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_ld_coo_sparse_mat) - call a%cp_from_coo(b,info) - class default - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_cp_from_fmt - - -subroutine psb_ld_base_mv_to_coo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_mv_to_coo - -subroutine psb_ld_base_mv_from_coo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - -8 -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_mv_from_coo - - -subroutine psb_ld_base_mv_to_fmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_ld_coo_sparse_mat) - call a%mv_to_coo(b,info) - class default - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_ld_base_mv_to_fmt - -subroutine psb_ld_base_mv_from_fmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_ld_coo_sparse_mat) - call a%mv_from_coo(b,info) - class default - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_ld_base_mv_from_fmt - -subroutine psb_ld_base_clean_zeros(a, info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clean_zeros - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - ! - type(psb_ld_coo_sparse_mat) :: tmpcoo - - call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) - if (info == 0) call a%mv_from_coo(tmpcoo,info) - -end subroutine psb_ld_base_clean_zeros - - -subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_a - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_csput_a - -subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_v - use psb_d_base_vect_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_base_vect_type), intent(inout) :: val - class(psb_l_base_vect_type), intent(inout) :: ia, ja - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - integer(psb_lpk_) :: nzin, nzout - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput_v' - integer :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - if (a%is_dev()) call a%sync() - if (val%is_dev()) call val%sync() - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) - else - info = psb_err_invalid_mat_state_ - endif - if (info /= 0) then - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_csput_v - -subroutine psb_ld_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetrow - implicit none - - class(psb_ld_base_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_csgetrow - - - -! -! Here we have the base implementation of getblk and clip: -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetblk - implicit none - - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout - character(len=20) :: name='csget' - integer(psb_lpk_) :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - if (present(rscale)) then - rscale_=rscale - else - rscale_=.false. - end if - if (present(cscale)) then - cscale_=cscale - else - cscale_=.false. - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if (append_.and.(rscale_.or.cscale_)) then - write(psb_err_unit,*) & - & 'ld_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' - end if - - if (rscale_) then - call b%set_nrows(imax-imin+1) - else - call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) - end if - - if (cscale_) then - call b%set_ncols(jmax_-jmin_+1) - else - call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) - end if - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_csgetblk - - -subroutine psb_ld_base_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csclip - implicit none - - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_csclip - - -! -! Here we have the base implementation of tril and triu -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_ld_base_tril(a,l,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_tril - implicit none - - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(out) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ld_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - real(psb_dpk_), allocatable :: val(:) - character(len=20) :: name='tril' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call l%allocate(mb,nb,nz) - - if (present(u)) then - nzlin = l%get_nzeros() ! At this point it should be 0 - call u%allocate(mb,nb,nz) - nzuin = u%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i<=diag_) then - nzlin = nzlin + 1 - l%ia(nzlin) = ia(k) - l%ja(nzlin) = ja(k) - l%val(nzlin) = val(k) - else - nzuin = nzuin + 1 - u%ia(nzuin) = ia(k) - u%ja(nzuin) = ja(k) - u%val(nzuin) = val(k) - end if - end do - end do - - call l%set_nzeros(nzlin) - call u%set_nzeros(nzuin) - call u%fix(info) - nzout = u%get_nzeros() - if (rscale_) & - & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_lower(.false.) - end if - else - nzin = l%get_nzeros() ! At this point it should be 0 - do i=imin_,imax_ - k = min(jmax_,i+diag_) - call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& - & jmin=jmin_, jmax=k, append=.true., & - & nzin=nzin) - if (info /= psb_success_) goto 9999 - call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout - end do - end if - call l%fix(info) - nzout = l%get_nzeros() - if (rscale_) & - & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then - call l%set_triangle(.true.) - call l%set_lower(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_tril - -subroutine psb_ld_base_triu(a,u,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_triu - implicit none - - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(out) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ld_coo_sparse_mat), optional, intent(out) :: l - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - real(psb_dpk_), allocatable :: val(:) - character(len=20) :: name='triu' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call u%allocate(mb,nb,nz) - - if (present(l)) then - nzuin = u%get_nzeros() ! At this point it should be 0 - call l%allocate(mb,nb,nz) - nzlin = l%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i= 0).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_upper(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_triu - - - -subroutine psb_ld_base_clone(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clone - use psb_error_mod - implicit none - - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b, stat=info) - end if - if (info /= 0) then - info = psb_err_alloc_dealloc_ - return - end if - - ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. - allocate(b,mold=a,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - -end subroutine psb_ld_base_clone - -subroutine psb_ld_base_make_nonunit(a) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_make_nonunit - use psb_error_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - type(psb_ld_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i, j, m, n, nz, mnm - - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) - if (info /= 0) return - m = tmp%get_nrows() - n = tmp%get_ncols() - mnm = min(m,n) - nz = tmp%get_nzeros() - call tmp%reallocate(nz+mnm) - do i=1, mnm - tmp%val(nz+i) = done - tmp%ia(nz+i) = i - tmp%ja(nz+i) = i - end do - call tmp%set_nzeros(nz+mnm) - call tmp%set_unit(.false.) - call tmp%fix(info) - if (info /= 0) & - & call a%mv_from_coo(tmp,info) - end if - -end subroutine psb_ld_base_make_nonunit - -subroutine psb_ld_base_mold(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mold - use psb_error_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='base_mold' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_mold - -subroutine psb_ld_base_transp_2mat(a,b) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_2mat - use psb_error_mod - implicit none - - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_ld_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ld_base_transp' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_ld_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_transp_2mat - -subroutine psb_ld_base_transc_2mat(a,b) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_2mat - implicit none - - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_ld_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ld_base_transc' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_ld_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return -end subroutine psb_ld_base_transc_2mat - -subroutine psb_ld_base_transp_1mat(a) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_1mat - use psb_error_mod - implicit none - - class(psb_ld_base_sparse_mat), intent(inout) :: a - - type(psb_ld_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ld_base_transp' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_transp_1mat - -subroutine psb_ld_base_transc_1mat(a) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_1mat - implicit none - - class(psb_ld_base_sparse_mat), intent(inout) :: a - - type(psb_ld_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ld_base_transc' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_transc_1mat - - -! == ================================== -! -! -! -! Computational routines -! -! -! -! -! -! -! == ================================== - -subroutine psb_ld_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csmm - use psb_error_mod - - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_base_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_csmm - - -subroutine psb_ld_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csmv - use psb_error_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_base_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - - -end subroutine psb_ld_base_csmv - - -subroutine psb_ld_base_inner_cssm(alpha,a,x,beta,y,info,trans) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_inner_cssm - use psb_error_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_base_inner_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_inner_cssm - - -subroutine psb_ld_base_inner_cssv(alpha,a,x,beta,y,info,trans) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_inner_cssv - use psb_error_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_base_inner_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_inner_cssv - - -subroutine psb_ld_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cssm - use psb_error_mod - use psb_string_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - - real(psb_dpk_), allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='ld_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(done,x,dzero,tmp,info,trans) - - if (info == psb_success_)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == psb_success_) then - inar = nar - inc = nc - call psb_geaxpby(inar,inc,alpha,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_cssm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_cssm - - -subroutine psb_ld_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cssv - use psb_error_mod - use psb_string_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - - real(psb_dpk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='ld_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == dzero) then - call a%inner_spsm(alpha,x,dzero,y,info,trans) - if (info == psb_success_) call inner_vscal1(nar,d,y) - else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,dzero,tmp,info,trans) - - if (info == psb_success_) call inner_vscal1(nar,d,tmp) - if (info == psb_success_) then - inar = nar - call psb_geaxpby(inar,done,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return -contains - subroutine inner_vscal(n,d,x,y) - implicit none - integer(psb_lpk_), intent(in) :: n - real(psb_dpk_), intent(in) :: d(*),x(*) - real(psb_dpk_), intent(out) :: y(*) - integer(psb_lpk_) :: i - - do i=1,n - y(i) = d(i)*x(i) - end do - end subroutine inner_vscal - - - subroutine inner_vscal1(n,d,x) - implicit none - integer(psb_lpk_), intent(in) :: n - real(psb_dpk_), intent(in) :: d(*) - real(psb_dpk_), intent(inout) :: x(*) - integer(psb_lpk_) :: i - - do i=1,n - x(i) = d(i)*x(i) - end do - end subroutine inner_vscal1 - -end subroutine psb_ld_base_cssv - - -subroutine psb_ld_base_scals(d,a,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scals - use psb_error_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_scals' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_scals - - - -subroutine psb_ld_base_scal(d,a,info,side) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scal - use psb_error_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_scal' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_scal - - - -function psb_ld_base_maxval(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_maxval - - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='maxval' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - res = dzero - ! 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()) - - call psb_error_handler(err_act) - -end function psb_ld_base_maxval - - -function psb_ld_base_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnmi - - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnmi' - real(psb_dpk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = dzero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%arwsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_ld_base_csnmi - -function psb_ld_base_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnm1 - - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnm1' - real(psb_dpk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = dzero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%aclsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_ld_base_csnm1 - -subroutine psb_ld_base_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_rowsum - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_rowsum - -subroutine psb_ld_base_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_arwsum - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='arwsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_arwsum - -subroutine psb_ld_base_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_colsum - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_colsum - -subroutine psb_ld_base_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_aclsum - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_aclsum - - -subroutine psb_ld_base_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_get_diag - - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ld_base_get_diag - - -! == ================================== -! -! -! -! Computational routines for ld_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! -! -! -! -! == ================================== - - - -subroutine psb_ld_base_vect_mv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_vect_mv - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - ! For the time being we just throw everything back - ! onto the normal routines. - call x%sync() - call y%sync() - call a%spmm(alpha,x%v,beta,y%v,info,trans) - call y%set_host() -end subroutine psb_ld_base_vect_mv - -subroutine psb_ld_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_vect_cssv - use psb_d_base_vect_mod - use psb_error_mod - use psb_string_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_d_base_vect_type), intent(inout),optional :: d - - real(psb_dpk_), allocatable :: tmp(:) - class(psb_d_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='ld_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (x%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (y%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call x%sync() - call y%sync() - if (present(d)) then - call d%sync() - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (d%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(done,d%v(1:nac),x,dzero,info) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (d%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == dzero) then - call a%inner_spsm(alpha,x,dzero,y,info,trans) - if (info == psb_success_) call y%mlt(d%v(1:nar),info) - - else - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,dzero,tmpv,info,trans) - - if (info == psb_success_) call tmpv%mlt(d%v(1:nar),info) - if (info == psb_success_) then - inar = nar - call y%axpby(inar,done,tmpv,beta,info) - end if - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_vect_cssv - - -subroutine psb_ld_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_inner_vect_sv - use psb_error_mod - use psb_string_mod - use psb_d_base_vect_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_base_inner_vect_sv' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_inner_vect_sv - - - - -subroutine psb_ld_base_cp_to_icoo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_cp_to_icoo - -subroutine psb_ld_base_cp_from_icoo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call tmp%cp_from_icoo(b,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_cp_from_icoo - - -subroutine psb_ld_base_cp_to_ifmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_d_coo_sparse_mat) - call a%cp_to_icoo(b,info) - class default - call a%cp_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_cp_to_ifmt - -subroutine psb_ld_base_cp_from_ifmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_d_coo_sparse_mat) - call a%cp_from_icoo(b,info) - class default - call b%cp_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_cp_from_ifmt - - -subroutine psb_ld_base_mv_to_icoo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_icoo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_mv_to_icoo - -subroutine psb_ld_base_mv_from_icoo(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_base_mv_from_icoo - - -subroutine psb_ld_base_mv_to_ifmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_d_coo_sparse_mat) - call a%mv_to_icoo(b,info) - class default - call a%mv_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_ld_base_mv_to_ifmt - -subroutine psb_ld_base_mv_from_ifmt(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ld_base_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_ld_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_d_coo_sparse_mat) - call a%mv_from_icoo(b,info) - class default - call b%mv_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_ld_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_d_lcoo_impl.f90 b/base/serial/impl/psb_d_lcoo_impl.f90 deleted file mode 100644 index 1ecaae17..00000000 --- a/base/serial/impl/psb_d_lcoo_impl.f90 +++ /dev/null @@ -1,4127 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! - -subroutine psb_ld_coo_get_diag(a,d,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_diag - use psb_error_mod - use psb_const_mod - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - if (a%is_unit()) then - d(1:mnm) = done - else - d(1:mnm) = dzero - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_get_diag - - -subroutine psb_ld_coo_scal(d,a,info,side) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scal - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - character :: side_ - logical :: left - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - side_ = 'L' - if (present(side)) then - side_ = psb_toupper(side) - end if - - left = (side_ == 'L') - - if (left) then - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - else - m = a%get_ncols() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ja(i) - a%val(i) = a%val(i) * d(j) - enddo - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_scal - - -subroutine psb_ld_coo_scals(d,a,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scals - use psb_error_mod - use psb_const_mod - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_scals - - -subroutine psb_ld_coo_reallocate_nz(nz,a) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reallocate_nz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: nz - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='ld_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_reallocate_nz - -subroutine psb_ld_coo_mold(a,b,info) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mold - use psb_error_mod - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='coo_mold' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b,stat=info) - end if - if (info == 0) allocate(psb_ld_coo_sparse_mat :: b, stat=info) - - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info, name) - goto 9999 - end if - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_mold - -subroutine psb_ld_coo_reinit(a,clear) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reinit - use psb_error_mod - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = dzero - call a%set_host() - call a%set_upd() - else - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_reinit - - - -subroutine psb_ld_coo_trim(a) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_trim - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - nz = a%get_nzeros() - if (info == psb_success_) call psb_realloc(nz,a%ia,info) - if (info == psb_success_) call psb_realloc(nz,a%ja,info) - if (info == psb_success_) call psb_realloc(nz,a%val,info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_trim - -subroutine psb_ld_coo_clean_zeros(a, info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_zeros - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info - ! - integer(psb_lpk_) :: i,j,k, nzin - - info = 0 - nzin = a%get_nzeros() - j = 0 - do i=1, nzin - if (a%val(i) /= dzero) then - j = j + 1 - a%val(j) = a%val(i) - a%ia(j) = a%ia(i) - a%ja(j) = a%ja(i) - end if - end do - call a%set_nzeros(j) - call a%trim() -end subroutine psb_ld_coo_clean_zeros - - - -subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_allocate_mnnz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: m,n - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (m < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/ione,izero/)) - goto 9999 - endif - if (n < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) - goto 9999 - endif - if (present(nz)) then - nz_ = max(nz,ione) - else - nz_ = max(7*m,7*n,ione) - end if - if (nz_ < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) - goto 9999 - endif - if (info == psb_success_) call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(lzero) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - ! An empty matrix is sorted! - call a%set_sorted(.true.) - call a%set_host() - end if - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_allocate_mnnz - - - -subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_print - use psb_string_mod - implicit none - - integer(psb_ipk_), intent(in) :: iout - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_coo_print' - logical, parameter :: debug=.false. - - character(len=*), parameter :: datatype='real' - character(len=80) :: frmtv - integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz - - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - - if (a%is_dev()) call a%sync() - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - if (present(iv)) nmx = max(nmx,maxval(abs(iv))) - if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) - if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) - ni = floor(log10(1.0*nmx)) + 1 - - if (datatype=='real') then - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - else - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - end if - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - -end subroutine psb_ld_coo_print - - - - -function psb_ld_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_nz_row - implicit none - - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_) :: res - integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k - integer(psb_ipk_) :: inza - - if (a%is_dev()) call a%sync() - res = 0 - nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. - inza = nza - ip = psb_bsrch(idx,inza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - -end function psb_ld_coo_get_nz_row - -subroutine psb_ld_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cssm - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_base_csmm' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nc = min(size(x,2) , size(y,2)) - nnz = a%get_nzeros() - - if (alpha == dzero) then - if (beta == dzero) then - do i = 1, m - y(i,1:nc) = dzero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - end if - - if (beta == dzero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),y,size(y,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*y(i,1:nc) - end do - else - allocate(tmp(m,nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),tmp,size(tmp,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) - end do - end if - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='inner_coosm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - - -contains - - subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) - real(psb_dpk_), intent(in) :: val(*), x(ldx,*) - real(psb_dpk_), intent(out) :: y(ldy,*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc - real(psb_dpk_), allocatable :: acc(:) - - info = psb_success_ - allocate(acc(nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - return - end if - - - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = dzero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc(1:nc) = dzero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j + 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = dzero - do - if (j < 1) exit - if (ia(j) < i) exit - acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) - j = j - 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc(1:nc) = dzero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j - 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / (val(j)) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / (val(j)) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - end if - end subroutine inner_coosm - -end subroutine psb_ld_coo_cssm - - - -subroutine psb_ld_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cssv - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_coo_cssv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (alpha == dzero) then - if (beta == dzero) then - do i = 1, m - y(i) = dzero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - end if - - if (beta == dzero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,y,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*y(i) - end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,tmp,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*tmp(i) + beta*y(i) - end do - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nz,ia(*),ja(*) - real(psb_dpk_), intent(in) :: val(*), x(*) - real(psb_dpk_), intent(out) :: y(*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc, nnz - real(psb_dpk_) :: acc - - info = psb_success_ - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc = dzero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - y(i) = x(i) - acc - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc = dzero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j + 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = dzero - do - if (j < 1) exit - if (ia(j) < i) exit - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - y(i) = x(i) - acc - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc = dzero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j - 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /(val(j)) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /(val(j)) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j + 1 - end do - end do - end if - end if - end if - end if - - end subroutine inner_coosv - - -end subroutine psb_ld_coo_cssv - -subroutine psb_ld_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csmv - implicit none - - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_coo_csmv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - if (alpha == dzero) then - if (beta == dzero) then - do i = 1, m - y(i) = dzero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - else - if (a%is_unit()) then - if (beta == dzero) then - do i = 1, min(m,n) - y(i) = alpha*x(i) - enddo - do i = min(m,n)+1, m - y(i) = dzero - enddo - else - do i = 1, min(m,n) - y(i) = beta*y(i) + alpha*x(i) - end do - do i = min(m,n)+1, m - y(i) = beta*y(i) - enddo - endif - else - if (beta == dzero) then - do i = 1, m - y(i) = dzero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - - endif - - end if - - if ((.not.tra).and.(.not.ctra)) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = dzero - do - if (i>nnz) then - y(ir) = y(ir) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir) = y(ir) + alpha * acc - ir = a%ia(i) - acc = dzero - endif - acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == done) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + a%val(i)*x(jc) - enddo - - else if (alpha == -done) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - a%val(i)*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*a%val(i)*x(jc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == done) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + (a%val(i))*x(jc) - enddo - - else if (alpha == -done) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - (a%val(i))*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*(a%val(i))*x(jc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_csmv - - -subroutine psb_ld_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csmm - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_), allocatable :: acc(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_coo_csmm_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - nc = min(size(x,2), size(y,2)) - allocate(acc(nc),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - - if (alpha == dzero) then - if (beta == dzero) then - do i = 1, m - y(i,1:nc) = dzero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - else - if (a%is_unit()) then - if (beta == dzero) then - do i = 1, min(m,n) - y(i,1:nc) = alpha*x(i,1:nc) - enddo - do i = min(m,n)+1, m - y(i,1:nc) = dzero - enddo - else - do i = 1, min(m,n) - y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) - end do - do i = min(m,n)+1, m - y(i,1:nc) = beta*y(i,1:nc) - enddo - endif - else - if (beta == dzero) then - do i = 1, m - y(i,1:nc) = dzero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - - endif - - end if - - if (.not.tra) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = dzero - do - if (i>nnz) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) - acc = dzero - endif - acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == done) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) - enddo - - else if (alpha == -done) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == done) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + (a%val(i))*x(jc,1:nc) - enddo - - else if (alpha == -done) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - (a%val(i))*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*(a%val(i))*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_csmm - -function psb_ld_coo_maxval(a) result(res) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_maxval - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - character(len=20) :: name='ld_coo_maxval' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - res = done - else - res = dzero - end if - nnz = a%get_nzeros() - if (allocated(a%val)) then - nnz = min(nnz,size(a%val)) - res = maxval(abs(a%val(1:nnz))) - end if - -end function psb_ld_coo_maxval - -function psb_ld_coo_csnmi(a) result(res) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnmi - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra, is_unit - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='ld_coo_csnmi' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = dzero - nnz = a%get_nzeros() - is_unit = a%is_unit() - if (a%is_by_rows()) 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 - if (is_unit) then - acc = done - else - acc = dzero - end if - 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 - if (is_unit) then - vt = done - else - vt = dzero - end if - do j=1, nnz - i = a%ia(j) - vt(i) = vt(i) + abs(a%val(j)) - end do - res = maxval(vt(1:m)) - deallocate(vt,stat=info) - end if - -end function psb_ld_coo_csnmi - - -function psb_ld_coo_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnm1 - - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='ld_coo_csnm1' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = dzero - nnz = a%get_nzeros() - n = a%get_ncols() - allocate(vt(n),stat=info) - if (info /= 0) return - if (a%is_unit()) then - vt = done - else - vt = dzero - end if - 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) - - return - -end function psb_ld_coo_csnm1 - -subroutine psb_ld_coo_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_rowsum - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = done - else - d = dzero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_rowsum - -subroutine psb_ld_coo_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_arwsum - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = done - else - d = dzero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_arwsum - -subroutine psb_ld_coo_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_colsum - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - if (a%is_unit()) then - d = done - else - d = dzero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_colsum - -subroutine psb_ld_coo_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_aclsum - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - - if (a%is_unit()) then - d = done - else - d = dzero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_aclsum - - - -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - - - -subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csgetptn - implicit none - - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = iren(a%ia(i)) - ja(nzin_) = iren(a%ja(i)) - end if - enddo - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = a%ia(i) - ja(nzin_) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - end if - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - end if - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - nzin_=nzin_+k - end if - nz = k - end if - - end subroutine coo_getptn - -end subroutine psb_ld_coo_csgetptn - - -! -! NZ is the number of non-zeros on output. -! The output is guaranteed to be sorted -! -subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csgetrow - implicit none - - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = iren(a%ia(i)) - ja(nzin_+nz) = iren(a%ja(i)) - end if - enddo - call psb_ld_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = a%ia(i) - ja(nzin_+nz) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - end if - call psb_ld_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - end if - - end subroutine coo_getrow - -end subroutine psb_ld_coo_csgetrow - - -subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csput_a - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ld_coo_csput_a_impl' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: nza, i,j,k, nzl, isza - integer(psb_ipk_) :: debug_level, debug_unit - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (nz < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) - goto 9999 - end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) - goto 9999 - end if - - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) - goto 9999 - end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) - goto 9999 - end if - - if (nz == 0) return - - - nza = a%get_nzeros() - isza = a%get_size() - if (a%is_bld()) then - ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then - call a%reallocate(max(nza+nz,int(1.5*isza))) - endif - isza = a%get_size() - if (isza < (nza+nz)) then - info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 - end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& - & imin,imax,jmin,jmax,info,gtl) - call a%set_nzeros(nza) - call a%set_sorted(.false.) - - - else if (a%is_upd()) then - - if (a%is_dev()) call a%sync() - - call ld_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - if (info < 0) then - info = psb_err_internal_error_ - else if (info > 0) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' - info = psb_success_ - end if - else - ! State is wrong. - info = psb_err_invalid_mat_state_ - end if - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl) - implicit none - - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) - real(psb_dpk_), intent(in) :: val(:) - real(psb_dpk_), intent(inout) :: aspk(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic,ng - - info = psb_success_ - if (present(gtl)) then - ng = size(gtl) - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - - - subroutine ld_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nnz,dupl,ng, nr - integer(psb_ipk_) :: debug_level, debug_unit, innz, nc - character(len=20) :: name='ld_coo_srch_upd' - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - dupl = a%get_dupl() - - if (.not.a%is_sorted()) then - info = -4 - return - end if - - ilr = -1 - ilc = -1 - nnz = a%get_nzeros() - nr = a%get_nrows() - innz = nnz - - if (present(gtl)) then - ng = size(gtl) - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= nr)) then - ic = gtl(ic) - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - endif - else - info = max(info,1) - end if - end do - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - else - info = max(info,1) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - end if - - end subroutine ld_coo_srch_upd - -end subroutine psb_ld_coo_csput_a - - -subroutine psb_ld_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_coo - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_cp_coo_to_coo - -subroutine psb_ld_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_coo - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_cp_coo_from_coo - - -subroutine psb_ld_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_fmt - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_cp_coo_to_fmt - -subroutine psb_ld_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_fmt - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_cp_coo_from_fmt - - -subroutine psb_ld_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_coo - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - call b%set_nzeros(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call b%set_host() - call a%free() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_mv_coo_to_coo - -subroutine psb_ld_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_coo - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - call a%set_nzeros(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_mv_coo_from_coo - - -subroutine psb_ld_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_fmt - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_mv_coo_to_fmt - -subroutine psb_ld_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_fmt - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_ld_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_mv_coo_from_fmt - -subroutine psb_ld_coo_cp_from(a,b) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cp_from - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - type(psb_ld_coo_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%cp_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_cp_from - -subroutine psb_ld_coo_mv_from(a,b) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mv_from - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - type(psb_ld_coo_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_coo_mv_from - - - -subroutine psb_ld_fix_coo(a,info,idir) - use psb_const_mod - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo - implicit none - - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - integer(psb_lpk_), allocatable :: iaux(:) - !locals - integer(psb_lpk_) :: nza, nzl,iret, nra, nca - integer(psb_lpk_) :: i,j, irw, icl - integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ - character(len=20) :: name = 'psb_fixcoo' - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia),size(a%ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - if (a%is_dev()) call a%sync() - - nra = a%get_nrows() - nca = a%get_ncols() - nza = a%get_nzeros() - if (nza >= 2) then - dupl_ = a%get_dupl() - call psb_ld_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= psb_success_) goto 9999 - else - i = nza - end if - call a%set_sort_status(idir_) - call a%set_nzeros(i) - call a%set_asb() - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_fix_coo - - - -subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo_inner - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod - implicit none - - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_lpk_), intent(inout) :: ia(:), ja(:) - real(psb_dpk_), intent(inout) :: val(:) - integer(psb_lpk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - !locals - integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) - real(psb_dpk_), allocatable :: vs(:) - integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin - integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(ia),size(ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - - - if (nzin < 2) then - call psb_erractionrestore(err_act) - return - end if - - dupl_ = dupl - - - - allocate(iaux(max(nr,nc,nzin)+2),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) - use_buffers = (info == 0) - - select case(idir_) - - case(psb_row_major_) - ! Row major order - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then - iaux(:) = 0 - iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ia(i)) = iaux(ia(i)) + 1 - srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) - end do - else - use_buffers=.false. - end if - end if - ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major - ! we can do it row-by-row here. - k = 0 - i = 1 - do j=1, nr - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ja(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already row-major - ! we have to sort all - - ip = iaux(1) - iaux(1) = 0 - do i=2, nr - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nr+1) = ip - - do i=1,nzin - irw = ia(i) - ip = iaux(irw) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(irw) = ip - end do - k = 0 - i = 1 - do j=1, nr - - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,jas(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - ! - ! If we did not have enough memory for buffers, - ! let's try in place. - ! - inzin = nzin - call psi_msort_up(inzin,ia(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - - do while ((ia(j) == ia(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ja(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - endif - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - - case(psb_col_major_) - - if (use_buffers) then - iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then - iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ja(i)) = iaux(ja(i)) + 1 - srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do - else - use_buffers=.false. - end if - end if - !use_buffers=use_buffers.and.srt_inp - ! Check again use_buffers. - if (use_buffers) then - - if (srt_inp) then - ! If input was already col-major - ! we can do it col-by-col here. - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already col-major - ! we have to sort all - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - inzin = nzin - call psi_msort_up(inzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 - end select - - nzout = i - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_fix_coo_inner - - -subroutine psb_ld_cp_coo_to_icoo(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_icoo - implicit none - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_base_sparse_mat = a%psb_lbase_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_cp_coo_to_icoo - -subroutine psb_ld_cp_coo_from_icoo(a,b,info) - use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_icoo - implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lbase_sparse_mat = b%psb_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ld_cp_coo_from_icoo - diff --git a/base/serial/impl/psb_s_lbase_mat_impl.F90 b/base/serial/impl/psb_s_lbase_mat_impl.F90 deleted file mode 100644 index 8f0569f3..00000000 --- a/base/serial/impl/psb_s_lbase_mat_impl.F90 +++ /dev/null @@ -1,2320 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - -subroutine psb_ls_base_cp_to_coo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_cp_to_coo - -subroutine psb_ls_base_cp_from_coo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_ls_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_cp_from_coo - - -subroutine psb_ls_base_cp_to_fmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_ls_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_ls_coo_sparse_mat) - call a%cp_to_coo(b,info) - class default - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_cp_to_fmt - -subroutine psb_ls_base_cp_from_fmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_ls_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_ls_coo_sparse_mat) - call a%cp_from_coo(b,info) - class default - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_cp_from_fmt - - -subroutine psb_ls_base_mv_to_coo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_mv_to_coo - -subroutine psb_ls_base_mv_from_coo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - -8 -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_mv_from_coo - - -subroutine psb_ls_base_mv_to_fmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_ls_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_ls_coo_sparse_mat) - call a%mv_to_coo(b,info) - class default - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_ls_base_mv_to_fmt - -subroutine psb_ls_base_mv_from_fmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_ls_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_ls_coo_sparse_mat) - call a%mv_from_coo(b,info) - class default - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_ls_base_mv_from_fmt - -subroutine psb_ls_base_clean_zeros(a, info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clean_zeros - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - ! - type(psb_ls_coo_sparse_mat) :: tmpcoo - - call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) - if (info == 0) call a%mv_from_coo(tmpcoo,info) - -end subroutine psb_ls_base_clean_zeros - - -subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_a - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_csput_a - -subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_v - use psb_s_base_vect_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_s_base_vect_type), intent(inout) :: val - class(psb_l_base_vect_type), intent(inout) :: ia, ja - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - integer(psb_lpk_) :: nzin, nzout - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput_v' - integer :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - if (a%is_dev()) call a%sync() - if (val%is_dev()) call val%sync() - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) - else - info = psb_err_invalid_mat_state_ - endif - if (info /= 0) then - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_csput_v - -subroutine psb_ls_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetrow - implicit none - - class(psb_ls_base_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_csgetrow - - - -! -! Here we have the base implementation of getblk and clip: -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetblk - implicit none - - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout - character(len=20) :: name='csget' - integer(psb_lpk_) :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - if (present(rscale)) then - rscale_=rscale - else - rscale_=.false. - end if - if (present(cscale)) then - cscale_=cscale - else - cscale_=.false. - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if (append_.and.(rscale_.or.cscale_)) then - write(psb_err_unit,*) & - & 'ls_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' - end if - - if (rscale_) then - call b%set_nrows(imax-imin+1) - else - call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) - end if - - if (cscale_) then - call b%set_ncols(jmax_-jmin_+1) - else - call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) - end if - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_csgetblk - - -subroutine psb_ls_base_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csclip - implicit none - - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_ls_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_csclip - - -! -! Here we have the base implementation of tril and triu -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_ls_base_tril(a,l,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_tril - implicit none - - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_ls_coo_sparse_mat), intent(out) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ls_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - real(psb_spk_), allocatable :: val(:) - character(len=20) :: name='tril' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call l%allocate(mb,nb,nz) - - if (present(u)) then - nzlin = l%get_nzeros() ! At this point it should be 0 - call u%allocate(mb,nb,nz) - nzuin = u%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i<=diag_) then - nzlin = nzlin + 1 - l%ia(nzlin) = ia(k) - l%ja(nzlin) = ja(k) - l%val(nzlin) = val(k) - else - nzuin = nzuin + 1 - u%ia(nzuin) = ia(k) - u%ja(nzuin) = ja(k) - u%val(nzuin) = val(k) - end if - end do - end do - - call l%set_nzeros(nzlin) - call u%set_nzeros(nzuin) - call u%fix(info) - nzout = u%get_nzeros() - if (rscale_) & - & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_lower(.false.) - end if - else - nzin = l%get_nzeros() ! At this point it should be 0 - do i=imin_,imax_ - k = min(jmax_,i+diag_) - call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& - & jmin=jmin_, jmax=k, append=.true., & - & nzin=nzin) - if (info /= psb_success_) goto 9999 - call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout - end do - end if - call l%fix(info) - nzout = l%get_nzeros() - if (rscale_) & - & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then - call l%set_triangle(.true.) - call l%set_lower(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_tril - -subroutine psb_ls_base_triu(a,u,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_triu - implicit none - - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_ls_coo_sparse_mat), intent(out) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_ls_coo_sparse_mat), optional, intent(out) :: l - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - real(psb_spk_), allocatable :: val(:) - character(len=20) :: name='triu' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call u%allocate(mb,nb,nz) - - if (present(l)) then - nzuin = u%get_nzeros() ! At this point it should be 0 - call l%allocate(mb,nb,nz) - nzlin = l%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i= 0).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_upper(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_triu - - - -subroutine psb_ls_base_clone(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clone - use psb_error_mod - implicit none - - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_ls_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b, stat=info) - end if - if (info /= 0) then - info = psb_err_alloc_dealloc_ - return - end if - - ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. - allocate(b,mold=a,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - -end subroutine psb_ls_base_clone - -subroutine psb_ls_base_make_nonunit(a) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_make_nonunit - use psb_error_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - type(psb_ls_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i, j, m, n, nz, mnm - - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) - if (info /= 0) return - m = tmp%get_nrows() - n = tmp%get_ncols() - mnm = min(m,n) - nz = tmp%get_nzeros() - call tmp%reallocate(nz+mnm) - do i=1, mnm - tmp%val(nz+i) = sone - tmp%ia(nz+i) = i - tmp%ja(nz+i) = i - end do - call tmp%set_nzeros(nz+mnm) - call tmp%set_unit(.false.) - call tmp%fix(info) - if (info /= 0) & - & call a%mv_from_coo(tmp,info) - end if - -end subroutine psb_ls_base_make_nonunit - -subroutine psb_ls_base_mold(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mold - use psb_error_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='base_mold' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_mold - -subroutine psb_ls_base_transp_2mat(a,b) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_2mat - use psb_error_mod - implicit none - - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_ls_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ls_base_transp' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_ls_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_transp_2mat - -subroutine psb_ls_base_transc_2mat(a,b) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_2mat - implicit none - - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_ls_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ls_base_transc' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_ls_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return -end subroutine psb_ls_base_transc_2mat - -subroutine psb_ls_base_transp_1mat(a) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_1mat - use psb_error_mod - implicit none - - class(psb_ls_base_sparse_mat), intent(inout) :: a - - type(psb_ls_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ls_base_transp' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_transp_1mat - -subroutine psb_ls_base_transc_1mat(a) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_1mat - implicit none - - class(psb_ls_base_sparse_mat), intent(inout) :: a - - type(psb_ls_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='ls_base_transc' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_transc_1mat - - -! == ================================== -! -! -! -! Computational routines -! -! -! -! -! -! -! == ================================== - -subroutine psb_ls_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csmm - use psb_error_mod - - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_base_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_csmm - - -subroutine psb_ls_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csmv - use psb_error_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_base_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - - -end subroutine psb_ls_base_csmv - - -subroutine psb_ls_base_inner_cssm(alpha,a,x,beta,y,info,trans) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_inner_cssm - use psb_error_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_base_inner_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_inner_cssm - - -subroutine psb_ls_base_inner_cssv(alpha,a,x,beta,y,info,trans) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_inner_cssv - use psb_error_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_base_inner_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_inner_cssv - - -subroutine psb_ls_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cssm - use psb_error_mod - use psb_string_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - - real(psb_spk_), allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='ls_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(sone,x,szero,tmp,info,trans) - - if (info == psb_success_)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == psb_success_) then - inar = nar - inc = nc - call psb_geaxpby(inar,inc,alpha,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_cssm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_cssm - - -subroutine psb_ls_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cssv - use psb_error_mod - use psb_string_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - - real(psb_spk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='ls_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == szero) then - call a%inner_spsm(alpha,x,szero,y,info,trans) - if (info == psb_success_) call inner_vscal1(nar,d,y) - else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,szero,tmp,info,trans) - - if (info == psb_success_) call inner_vscal1(nar,d,tmp) - if (info == psb_success_) then - inar = nar - call psb_geaxpby(inar,sone,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return -contains - subroutine inner_vscal(n,d,x,y) - implicit none - integer(psb_lpk_), intent(in) :: n - real(psb_spk_), intent(in) :: d(*),x(*) - real(psb_spk_), intent(out) :: y(*) - integer(psb_lpk_) :: i - - do i=1,n - y(i) = d(i)*x(i) - end do - end subroutine inner_vscal - - - subroutine inner_vscal1(n,d,x) - implicit none - integer(psb_lpk_), intent(in) :: n - real(psb_spk_), intent(in) :: d(*) - real(psb_spk_), intent(inout) :: x(*) - integer(psb_lpk_) :: i - - do i=1,n - x(i) = d(i)*x(i) - end do - end subroutine inner_vscal1 - -end subroutine psb_ls_base_cssv - - -subroutine psb_ls_base_scals(d,a,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scals - use psb_error_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_scals' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_scals - - - -subroutine psb_ls_base_scal(d,a,info,side) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scal - use psb_error_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_scal' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_scal - - - -function psb_ls_base_maxval(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_maxval - - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='maxval' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - res = szero - ! 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()) - - call psb_error_handler(err_act) - -end function psb_ls_base_maxval - - -function psb_ls_base_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnmi - - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnmi' - real(psb_spk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = szero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%arwsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_ls_base_csnmi - -function psb_ls_base_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnm1 - - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnm1' - real(psb_spk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = szero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%aclsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_ls_base_csnm1 - -subroutine psb_ls_base_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_rowsum - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_rowsum - -subroutine psb_ls_base_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_arwsum - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='arwsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_arwsum - -subroutine psb_ls_base_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_colsum - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_colsum - -subroutine psb_ls_base_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_aclsum - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_aclsum - - -subroutine psb_ls_base_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_get_diag - - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_ls_base_get_diag - - -! == ================================== -! -! -! -! Computational routines for ls_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! -! -! -! -! == ================================== - - - -subroutine psb_ls_base_vect_mv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_vect_mv - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - ! For the time being we just throw everything back - ! onto the normal routines. - call x%sync() - call y%sync() - call a%spmm(alpha,x%v,beta,y%v,info,trans) - call y%set_host() -end subroutine psb_ls_base_vect_mv - -subroutine psb_ls_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_vect_cssv - use psb_s_base_vect_mod - use psb_error_mod - use psb_string_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - class(psb_s_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_s_base_vect_type), intent(inout),optional :: d - - real(psb_spk_), allocatable :: tmp(:) - class(psb_s_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='ls_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (x%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (y%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call x%sync() - call y%sync() - if (present(d)) then - call d%sync() - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (d%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(sone,d%v(1:nac),x,szero,info) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (d%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == szero) then - call a%inner_spsm(alpha,x,szero,y,info,trans) - if (info == psb_success_) call y%mlt(d%v(1:nar),info) - - else - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,szero,tmpv,info,trans) - - if (info == psb_success_) call tmpv%mlt(d%v(1:nar),info) - if (info == psb_success_) then - inar = nar - call y%axpby(inar,sone,tmpv,beta,info) - end if - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_vect_cssv - - -subroutine psb_ls_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_inner_vect_sv - use psb_error_mod - use psb_string_mod - use psb_s_base_vect_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - class(psb_s_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_base_inner_vect_sv' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_inner_vect_sv - - - - -subroutine psb_ls_base_cp_to_icoo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_cp_to_icoo - -subroutine psb_ls_base_cp_from_icoo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call tmp%cp_from_icoo(b,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_cp_from_icoo - - -subroutine psb_ls_base_cp_to_ifmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_s_coo_sparse_mat) - call a%cp_to_icoo(b,info) - class default - call a%cp_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_cp_to_ifmt - -subroutine psb_ls_base_cp_from_ifmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_s_coo_sparse_mat) - call a%cp_from_icoo(b,info) - class default - call b%cp_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_cp_from_ifmt - - -subroutine psb_ls_base_mv_to_icoo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_icoo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_mv_to_icoo - -subroutine psb_ls_base_mv_from_icoo(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_base_mv_from_icoo - - -subroutine psb_ls_base_mv_to_ifmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_s_coo_sparse_mat) - call a%mv_to_icoo(b,info) - class default - call a%mv_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_ls_base_mv_to_ifmt - -subroutine psb_ls_base_mv_from_ifmt(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_ls_base_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_ls_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_s_coo_sparse_mat) - call a%mv_from_icoo(b,info) - class default - call b%mv_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_ls_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_s_lcoo_impl.f90 b/base/serial/impl/psb_s_lcoo_impl.f90 deleted file mode 100644 index ca02aee1..00000000 --- a/base/serial/impl/psb_s_lcoo_impl.f90 +++ /dev/null @@ -1,4127 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! - -subroutine psb_ls_coo_get_diag(a,d,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_diag - use psb_error_mod - use psb_const_mod - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - if (a%is_unit()) then - d(1:mnm) = sone - else - d(1:mnm) = szero - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_get_diag - - -subroutine psb_ls_coo_scal(d,a,info,side) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scal - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - character :: side_ - logical :: left - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - side_ = 'L' - if (present(side)) then - side_ = psb_toupper(side) - end if - - left = (side_ == 'L') - - if (left) then - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - else - m = a%get_ncols() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ja(i) - a%val(i) = a%val(i) * d(j) - enddo - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_scal - - -subroutine psb_ls_coo_scals(d,a,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scals - use psb_error_mod - use psb_const_mod - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_scals - - -subroutine psb_ls_coo_reallocate_nz(nz,a) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reallocate_nz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: nz - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='ls_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_reallocate_nz - -subroutine psb_ls_coo_mold(a,b,info) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mold - use psb_error_mod - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='coo_mold' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b,stat=info) - end if - if (info == 0) allocate(psb_ls_coo_sparse_mat :: b, stat=info) - - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info, name) - goto 9999 - end if - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_mold - -subroutine psb_ls_coo_reinit(a,clear) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reinit - use psb_error_mod - implicit none - - class(psb_ls_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = szero - call a%set_host() - call a%set_upd() - else - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_reinit - - - -subroutine psb_ls_coo_trim(a) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_trim - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - nz = a%get_nzeros() - if (info == psb_success_) call psb_realloc(nz,a%ia,info) - if (info == psb_success_) call psb_realloc(nz,a%ja,info) - if (info == psb_success_) call psb_realloc(nz,a%val,info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_trim - -subroutine psb_ls_coo_clean_zeros(a, info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_zeros - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info - ! - integer(psb_lpk_) :: i,j,k, nzin - - info = 0 - nzin = a%get_nzeros() - j = 0 - do i=1, nzin - if (a%val(i) /= szero) then - j = j + 1 - a%val(j) = a%val(i) - a%ia(j) = a%ia(i) - a%ja(j) = a%ja(i) - end if - end do - call a%set_nzeros(j) - call a%trim() -end subroutine psb_ls_coo_clean_zeros - - - -subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_allocate_mnnz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: m,n - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (m < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/ione,izero/)) - goto 9999 - endif - if (n < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) - goto 9999 - endif - if (present(nz)) then - nz_ = max(nz,ione) - else - nz_ = max(7*m,7*n,ione) - end if - if (nz_ < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) - goto 9999 - endif - if (info == psb_success_) call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(lzero) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - ! An empty matrix is sorted! - call a%set_sorted(.true.) - call a%set_host() - end if - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_allocate_mnnz - - - -subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_print - use psb_string_mod - implicit none - - integer(psb_ipk_), intent(in) :: iout - class(psb_ls_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_coo_print' - logical, parameter :: debug=.false. - - character(len=*), parameter :: datatype='real' - character(len=80) :: frmtv - integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz - - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - - if (a%is_dev()) call a%sync() - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - if (present(iv)) nmx = max(nmx,maxval(abs(iv))) - if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) - if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) - ni = floor(log10(1.0*nmx)) + 1 - - if (datatype=='real') then - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - else - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - end if - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - -end subroutine psb_ls_coo_print - - - - -function psb_ls_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_nz_row - implicit none - - class(psb_ls_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_) :: res - integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k - integer(psb_ipk_) :: inza - - if (a%is_dev()) call a%sync() - res = 0 - nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. - inza = nza - ip = psb_bsrch(idx,inza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - -end function psb_ls_coo_get_nz_row - -subroutine psb_ls_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cssm - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:,:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_base_csmm' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nc = min(size(x,2) , size(y,2)) - nnz = a%get_nzeros() - - if (alpha == szero) then - if (beta == szero) then - do i = 1, m - y(i,1:nc) = szero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - end if - - if (beta == szero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),y,size(y,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*y(i,1:nc) - end do - else - allocate(tmp(m,nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),tmp,size(tmp,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) - end do - end if - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='inner_coosm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - - -contains - - subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) - real(psb_spk_), intent(in) :: val(*), x(ldx,*) - real(psb_spk_), intent(out) :: y(ldy,*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc - real(psb_spk_), allocatable :: acc(:) - - info = psb_success_ - allocate(acc(nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - return - end if - - - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = szero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc(1:nc) = szero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j + 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = szero - do - if (j < 1) exit - if (ia(j) < i) exit - acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) - j = j - 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc(1:nc) = szero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j - 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / (val(j)) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / (val(j)) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - end if - end subroutine inner_coosm - -end subroutine psb_ls_coo_cssm - - - -subroutine psb_ls_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cssv - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_coo_cssv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (alpha == szero) then - if (beta == szero) then - do i = 1, m - y(i) = szero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - end if - - if (beta == szero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,y,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*y(i) - end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,tmp,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*tmp(i) + beta*y(i) - end do - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nz,ia(*),ja(*) - real(psb_spk_), intent(in) :: val(*), x(*) - real(psb_spk_), intent(out) :: y(*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc, nnz - real(psb_spk_) :: acc - - info = psb_success_ - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc = szero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - y(i) = x(i) - acc - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc = szero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j + 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = szero - do - if (j < 1) exit - if (ia(j) < i) exit - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - y(i) = x(i) - acc - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc = szero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j - 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /(val(j)) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /(val(j)) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j + 1 - end do - end do - end if - end if - end if - end if - - end subroutine inner_coosv - - -end subroutine psb_ls_coo_cssv - -subroutine psb_ls_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csmv - implicit none - - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_coo_csmv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - if (alpha == szero) then - if (beta == szero) then - do i = 1, m - y(i) = szero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - else - if (a%is_unit()) then - if (beta == szero) then - do i = 1, min(m,n) - y(i) = alpha*x(i) - enddo - do i = min(m,n)+1, m - y(i) = szero - enddo - else - do i = 1, min(m,n) - y(i) = beta*y(i) + alpha*x(i) - end do - do i = min(m,n)+1, m - y(i) = beta*y(i) - enddo - endif - else - if (beta == szero) then - do i = 1, m - y(i) = szero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - - endif - - end if - - if ((.not.tra).and.(.not.ctra)) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = szero - do - if (i>nnz) then - y(ir) = y(ir) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir) = y(ir) + alpha * acc - ir = a%ia(i) - acc = szero - endif - acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == sone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + a%val(i)*x(jc) - enddo - - else if (alpha == -sone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - a%val(i)*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*a%val(i)*x(jc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == sone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + (a%val(i))*x(jc) - enddo - - else if (alpha == -sone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - (a%val(i))*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*(a%val(i))*x(jc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_csmv - - -subroutine psb_ls_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csmm - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_), allocatable :: acc(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_coo_csmm_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - nc = min(size(x,2), size(y,2)) - allocate(acc(nc),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - - if (alpha == szero) then - if (beta == szero) then - do i = 1, m - y(i,1:nc) = szero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - else - if (a%is_unit()) then - if (beta == szero) then - do i = 1, min(m,n) - y(i,1:nc) = alpha*x(i,1:nc) - enddo - do i = min(m,n)+1, m - y(i,1:nc) = szero - enddo - else - do i = 1, min(m,n) - y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) - end do - do i = min(m,n)+1, m - y(i,1:nc) = beta*y(i,1:nc) - enddo - endif - else - if (beta == szero) then - do i = 1, m - y(i,1:nc) = szero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - - endif - - end if - - if (.not.tra) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = szero - do - if (i>nnz) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) - acc = szero - endif - acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == sone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) - enddo - - else if (alpha == -sone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == sone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + (a%val(i))*x(jc,1:nc) - enddo - - else if (alpha == -sone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - (a%val(i))*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*(a%val(i))*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_csmm - -function psb_ls_coo_maxval(a) result(res) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_maxval - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - character(len=20) :: name='ls_coo_maxval' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - res = sone - else - res = szero - end if - nnz = a%get_nzeros() - if (allocated(a%val)) then - nnz = min(nnz,size(a%val)) - res = maxval(abs(a%val(1:nnz))) - end if - -end function psb_ls_coo_maxval - -function psb_ls_coo_csnmi(a) result(res) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnmi - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra, is_unit - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='ls_coo_csnmi' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = szero - nnz = a%get_nzeros() - is_unit = a%is_unit() - if (a%is_by_rows()) then - i = 1 - j = i - res = szero - do while (i<=nnz) - do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) - j = j+1 - enddo - if (is_unit) then - acc = sone - else - acc = szero - end if - 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 - if (is_unit) then - vt = sone - else - vt = szero - end if - do j=1, nnz - i = a%ia(j) - vt(i) = vt(i) + abs(a%val(j)) - end do - res = maxval(vt(1:m)) - deallocate(vt,stat=info) - end if - -end function psb_ls_coo_csnmi - - -function psb_ls_coo_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnm1 - - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='ls_coo_csnm1' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = szero - nnz = a%get_nzeros() - n = a%get_ncols() - allocate(vt(n),stat=info) - if (info /= 0) return - if (a%is_unit()) then - vt = sone - else - vt = szero - end if - 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) - - return - -end function psb_ls_coo_csnm1 - -subroutine psb_ls_coo_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_rowsum - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = sone - else - d = szero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_rowsum - -subroutine psb_ls_coo_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_arwsum - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = sone - else - d = szero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_arwsum - -subroutine psb_ls_coo_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_colsum - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - if (a%is_unit()) then - d = sone - else - d = szero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_colsum - -subroutine psb_ls_coo_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_aclsum - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - - if (a%is_unit()) then - d = sone - else - d = szero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_aclsum - - - -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - - - -subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csgetptn - implicit none - - class(psb_ls_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = iren(a%ia(i)) - ja(nzin_) = iren(a%ja(i)) - end if - enddo - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = a%ia(i) - ja(nzin_) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - end if - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - end if - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - nzin_=nzin_+k - end if - nz = k - end if - - end subroutine coo_getptn - -end subroutine psb_ls_coo_csgetptn - - -! -! NZ is the number of non-zeros on output. -! The output is guaranteed to be sorted -! -subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csgetrow - implicit none - - class(psb_ls_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = iren(a%ia(i)) - ja(nzin_+nz) = iren(a%ja(i)) - end if - enddo - call psb_ls_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = a%ia(i) - ja(nzin_+nz) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - end if - call psb_ls_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - end if - - end subroutine coo_getrow - -end subroutine psb_ls_coo_csgetrow - - -subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csput_a - implicit none - - class(psb_ls_coo_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - - integer(psb_ipk_) :: err_act - character(len=20) :: name='ls_coo_csput_a_impl' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: nza, i,j,k, nzl, isza - integer(psb_ipk_) :: debug_level, debug_unit - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (nz < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) - goto 9999 - end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) - goto 9999 - end if - - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) - goto 9999 - end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) - goto 9999 - end if - - if (nz == 0) return - - - nza = a%get_nzeros() - isza = a%get_size() - if (a%is_bld()) then - ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then - call a%reallocate(max(nza+nz,int(1.5*isza))) - endif - isza = a%get_size() - if (isza < (nza+nz)) then - info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 - end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& - & imin,imax,jmin,jmax,info,gtl) - call a%set_nzeros(nza) - call a%set_sorted(.false.) - - - else if (a%is_upd()) then - - if (a%is_dev()) call a%sync() - - call ls_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - if (info < 0) then - info = psb_err_internal_error_ - else if (info > 0) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' - info = psb_success_ - end if - else - ! State is wrong. - info = psb_err_invalid_mat_state_ - end if - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl) - implicit none - - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) - real(psb_spk_), intent(in) :: val(:) - real(psb_spk_), intent(inout) :: aspk(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic,ng - - info = psb_success_ - if (present(gtl)) then - ng = size(gtl) - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - - - subroutine ls_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - implicit none - - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nnz,dupl,ng, nr - integer(psb_ipk_) :: debug_level, debug_unit, innz, nc - character(len=20) :: name='ls_coo_srch_upd' - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - dupl = a%get_dupl() - - if (.not.a%is_sorted()) then - info = -4 - return - end if - - ilr = -1 - ilc = -1 - nnz = a%get_nzeros() - nr = a%get_nrows() - innz = nnz - - if (present(gtl)) then - ng = size(gtl) - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= nr)) then - ic = gtl(ic) - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - endif - else - info = max(info,1) - end if - end do - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - else - info = max(info,1) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - end if - - end subroutine ls_coo_srch_upd - -end subroutine psb_ls_coo_csput_a - - -subroutine psb_ls_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_coo - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_cp_coo_to_coo - -subroutine psb_ls_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_coo - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - class(psb_ls_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_cp_coo_from_coo - - -subroutine psb_ls_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_fmt - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - class(psb_ls_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_cp_coo_to_fmt - -subroutine psb_ls_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_fmt - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - class(psb_ls_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_cp_coo_from_fmt - - -subroutine psb_ls_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_coo - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - call b%set_nzeros(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call b%set_host() - call a%free() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_mv_coo_to_coo - -subroutine psb_ls_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_coo - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - class(psb_ls_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - call a%set_nzeros(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_mv_coo_from_coo - - -subroutine psb_ls_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_fmt - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - class(psb_ls_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_mv_coo_to_fmt - -subroutine psb_ls_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_fmt - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - class(psb_ls_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_mv_coo_from_fmt - -subroutine psb_ls_coo_cp_from(a,b) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cp_from - implicit none - - class(psb_ls_coo_sparse_mat), intent(inout) :: a - type(psb_ls_coo_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%cp_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_cp_from - -subroutine psb_ls_coo_mv_from(a,b) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mv_from - implicit none - - class(psb_ls_coo_sparse_mat), intent(inout) :: a - type(psb_ls_coo_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_coo_mv_from - - - -subroutine psb_ls_fix_coo(a,info,idir) - use psb_const_mod - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo - implicit none - - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - integer(psb_lpk_), allocatable :: iaux(:) - !locals - integer(psb_lpk_) :: nza, nzl,iret, nra, nca - integer(psb_lpk_) :: i,j, irw, icl - integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ - character(len=20) :: name = 'psb_fixcoo' - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia),size(a%ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - if (a%is_dev()) call a%sync() - - nra = a%get_nrows() - nca = a%get_ncols() - nza = a%get_nzeros() - if (nza >= 2) then - dupl_ = a%get_dupl() - call psb_ls_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= psb_success_) goto 9999 - else - i = nza - end if - call a%set_sort_status(idir_) - call a%set_nzeros(i) - call a%set_asb() - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_fix_coo - - - -subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo_inner - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod - implicit none - - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_lpk_), intent(inout) :: ia(:), ja(:) - real(psb_spk_), intent(inout) :: val(:) - integer(psb_lpk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - !locals - integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) - real(psb_spk_), allocatable :: vs(:) - integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin - integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(ia),size(ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - - - if (nzin < 2) then - call psb_erractionrestore(err_act) - return - end if - - dupl_ = dupl - - - - allocate(iaux(max(nr,nc,nzin)+2),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) - use_buffers = (info == 0) - - select case(idir_) - - case(psb_row_major_) - ! Row major order - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then - iaux(:) = 0 - iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ia(i)) = iaux(ia(i)) + 1 - srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) - end do - else - use_buffers=.false. - end if - end if - ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major - ! we can do it row-by-row here. - k = 0 - i = 1 - do j=1, nr - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ja(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already row-major - ! we have to sort all - - ip = iaux(1) - iaux(1) = 0 - do i=2, nr - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nr+1) = ip - - do i=1,nzin - irw = ia(i) - ip = iaux(irw) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(irw) = ip - end do - k = 0 - i = 1 - do j=1, nr - - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,jas(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - ! - ! If we did not have enough memory for buffers, - ! let's try in place. - ! - inzin = nzin - call psi_msort_up(inzin,ia(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - - do while ((ia(j) == ia(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ja(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - endif - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - - case(psb_col_major_) - - if (use_buffers) then - iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then - iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ja(i)) = iaux(ja(i)) + 1 - srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do - else - use_buffers=.false. - end if - end if - !use_buffers=use_buffers.and.srt_inp - ! Check again use_buffers. - if (use_buffers) then - - if (srt_inp) then - ! If input was already col-major - ! we can do it col-by-col here. - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already col-major - ! we have to sort all - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - inzin = nzin - call psi_msort_up(inzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 - end select - - nzout = i - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_fix_coo_inner - - -subroutine psb_ls_cp_coo_to_icoo(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_icoo - implicit none - class(psb_ls_coo_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_base_sparse_mat = a%psb_lbase_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_cp_coo_to_icoo - -subroutine psb_ls_cp_coo_from_icoo(a,b,info) - use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_icoo - implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lbase_sparse_mat = b%psb_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_ls_cp_coo_from_icoo - diff --git a/base/serial/impl/psb_z_lbase_mat_impl.F90 b/base/serial/impl/psb_z_lbase_mat_impl.F90 deleted file mode 100644 index e78f3f87..00000000 --- a/base/serial/impl/psb_z_lbase_mat_impl.F90 +++ /dev/null @@ -1,2320 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - -subroutine psb_lz_base_cp_to_coo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_cp_to_coo - -subroutine psb_lz_base_cp_from_coo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_lz_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_cp_from_coo - - -subroutine psb_lz_base_cp_to_fmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lz_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_lz_coo_sparse_mat) - call a%cp_to_coo(b,info) - class default - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_cp_to_fmt - -subroutine psb_lz_base_cp_from_fmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_lz_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_lz_coo_sparse_mat) - call a%cp_from_coo(b,info) - class default - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_cp_from_fmt - - -subroutine psb_lz_base_mv_to_coo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_mv_to_coo - -subroutine psb_lz_base_mv_from_coo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_coo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - -8 -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_mv_from_coo - - -subroutine psb_lz_base_mv_to_fmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_lz_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_lz_coo_sparse_mat) - call a%mv_to_coo(b,info) - class default - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_lz_base_mv_to_fmt - -subroutine psb_lz_base_mv_from_fmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_fmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_lz_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_lz_coo_sparse_mat) - call a%mv_from_coo(b,info) - class default - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_lz_base_mv_from_fmt - -subroutine psb_lz_base_clean_zeros(a, info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clean_zeros - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - ! - type(psb_lz_coo_sparse_mat) :: tmpcoo - - call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) - if (info == 0) call a%mv_from_coo(tmpcoo,info) - -end subroutine psb_lz_base_clean_zeros - - -subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_a - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_csput_a - -subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_v - use psb_z_base_vect_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_z_base_vect_type), intent(inout) :: val - class(psb_l_base_vect_type), intent(inout) :: ia, ja - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - integer(psb_lpk_) :: nzin, nzout - integer(psb_ipk_) :: err_act - character(len=20) :: name='csput_v' - integer :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - if (a%is_dev()) call a%sync() - if (val%is_dev()) call val%sync() - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) - else - info = psb_err_invalid_mat_state_ - endif - if (info /= 0) then - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_csput_v - -subroutine psb_lz_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetrow - implicit none - - class(psb_lz_base_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_csgetrow - - - -! -! Here we have the base implementation of getblk and clip: -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetblk - implicit none - - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout - character(len=20) :: name='csget' - integer(psb_lpk_) :: jmin_, jmax_ - logical :: append_, rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - if (present(rscale)) then - rscale_=rscale - else - rscale_=.false. - end if - if (present(cscale)) then - cscale_=cscale - else - cscale_=.false. - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if (append_.and.(rscale_.or.cscale_)) then - write(psb_err_unit,*) & - & 'lz_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' - end if - - if (rscale_) then - call b%set_nrows(imax-imin+1) - else - call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) - end if - - if (cscale_) then - call b%set_ncols(jmax_-jmin_+1) - else - call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) - end if - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_csgetblk - - -subroutine psb_lz_base_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csclip - implicit none - - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lz_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= psb_success_) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_csclip - - -! -! Here we have the base implementation of tril and triu -! this is just based on the getrow. -! If performance is critical it can be overridden. -! -subroutine psb_lz_base_tril(a,l,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_tril - implicit none - - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lz_coo_sparse_mat), intent(out) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_lz_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - complex(psb_dpk_), allocatable :: val(:) - character(len=20) :: name='tril' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call l%allocate(mb,nb,nz) - - if (present(u)) then - nzlin = l%get_nzeros() ! At this point it should be 0 - call u%allocate(mb,nb,nz) - nzuin = u%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i<=diag_) then - nzlin = nzlin + 1 - l%ia(nzlin) = ia(k) - l%ja(nzlin) = ja(k) - l%val(nzlin) = val(k) - else - nzuin = nzuin + 1 - u%ia(nzuin) = ia(k) - u%ja(nzuin) = ja(k) - u%val(nzuin) = val(k) - end if - end do - end do - - call l%set_nzeros(nzlin) - call u%set_nzeros(nzuin) - call u%fix(info) - nzout = u%get_nzeros() - if (rscale_) & - & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_lower(.false.) - end if - else - nzin = l%get_nzeros() ! At this point it should be 0 - do i=imin_,imax_ - k = min(jmax_,i+diag_) - call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& - & jmin=jmin_, jmax=k, append=.true., & - & nzin=nzin) - if (info /= psb_success_) goto 9999 - call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout - end do - end if - call l%fix(info) - nzout = l%get_nzeros() - if (rscale_) & - & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 - if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then - call l%set_triangle(.true.) - call l%set_lower(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_tril - -subroutine psb_lz_base_triu(a,u,info,& - & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_triu - implicit none - - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lz_coo_sparse_mat), intent(out) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_lz_coo_sparse_mat), optional, intent(out) :: l - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k - integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_lpk_), allocatable :: ia(:), ja(:) - complex(psb_dpk_), allocatable :: val(:) - character(len=20) :: name='triu' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - if (present(diag)) then - diag_ = diag - else - diag_ = 0 - end if - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = imax_ - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = jmax_ - endif - - - nz = a%get_nzeros() - call u%allocate(mb,nb,nz) - - if (present(l)) then - nzuin = u%get_nzeros() ! At this point it should be 0 - call l%allocate(mb,nb,nz) - nzlin = l%get_nzeros() ! At this point it should be 0 - call psb_realloc(max(mb,nb),ia,info) - call psb_realloc(max(mb,nb),ja,info) - call psb_realloc(max(mb,nb),val,info) - do i=imin_,imax_ - call a%csget(i,i,nzout,ia,ja,val,info,& - & jmin=jmin_, jmax=jmax_) - do k=1, nzout - j = ja(k) - if (j-i= 0).and.(imin_ == jmin_)) then - call u%set_triangle(.true.) - call u%set_upper(.true.) - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_triu - - - -subroutine psb_lz_base_clone(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clone - use psb_error_mod - implicit none - - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_lz_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b, stat=info) - end if - if (info /= 0) then - info = psb_err_alloc_dealloc_ - return - end if - - ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. - allocate(b,mold=a,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - -end subroutine psb_lz_base_clone - -subroutine psb_lz_base_make_nonunit(a) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_make_nonunit - use psb_error_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - type(psb_lz_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i, j, m, n, nz, mnm - - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) - if (info /= 0) return - m = tmp%get_nrows() - n = tmp%get_ncols() - mnm = min(m,n) - nz = tmp%get_nzeros() - call tmp%reallocate(nz+mnm) - do i=1, mnm - tmp%val(nz+i) = zone - tmp%ia(nz+i) = i - tmp%ja(nz+i) = i - end do - call tmp%set_nzeros(nz+mnm) - call tmp%set_unit(.false.) - call tmp%fix(info) - if (info /= 0) & - & call a%mv_from_coo(tmp,info) - end if - -end subroutine psb_lz_base_make_nonunit - -subroutine psb_lz_base_mold(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mold - use psb_error_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='base_mold' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_mold - -subroutine psb_lz_base_transp_2mat(a,b) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_2mat - use psb_error_mod - implicit none - - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_lz_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lz_base_transp' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_lz_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_transp_2mat - -subroutine psb_lz_base_transc_2mat(a,b) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_2mat - implicit none - - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_lbase_sparse_mat), intent(out) :: b - - type(psb_lz_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lz_base_transc' - - call psb_erractionsave(err_act) - - info = psb_success_ - select type(b) - class is (psb_lz_base_sparse_mat) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call b%mv_from_coo(tmp,info) - class default - info = psb_err_invalid_dynamic_type_ - end select - if (info /= psb_success_) then - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return -end subroutine psb_lz_base_transc_2mat - -subroutine psb_lz_base_transp_1mat(a) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_1mat - use psb_error_mod - implicit none - - class(psb_lz_base_sparse_mat), intent(inout) :: a - - type(psb_lz_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lz_base_transp' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transp() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_transp_1mat - -subroutine psb_lz_base_transc_1mat(a) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_1mat - implicit none - - class(psb_lz_base_sparse_mat), intent(inout) :: a - - type(psb_lz_coo_sparse_mat) :: tmp - integer(psb_ipk_) :: err_act, info - character(len=*), parameter :: name='lz_base_transc' - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call tmp%transc() - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_transc_1mat - - -! == ================================== -! -! -! -! Computational routines -! -! -! -! -! -! -! == ================================== - -subroutine psb_lz_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csmm - use psb_error_mod - - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_base_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_csmm - - -subroutine psb_lz_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csmv - use psb_error_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_base_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - - -end subroutine psb_lz_base_csmv - - -subroutine psb_lz_base_inner_cssm(alpha,a,x,beta,y,info,trans) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_inner_cssm - use psb_error_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_base_inner_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_inner_cssm - - -subroutine psb_lz_base_inner_cssv(alpha,a,x,beta,y,info,trans) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_inner_cssv - use psb_error_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_base_inner_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_inner_cssv - - -subroutine psb_lz_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cssm - use psb_error_mod - use psb_string_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - - complex(psb_dpk_), allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='lz_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(zone,x,zzero,tmp,info,trans) - - if (info == psb_success_)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == psb_success_) then - inar = nar - inc = nc - call psb_geaxpby(inar,inc,alpha,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_cssm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_cssm - - -subroutine psb_lz_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cssv - use psb_error_mod - use psb_string_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - - complex(psb_dpk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='lz_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == zzero) then - call a%inner_spsm(alpha,x,zzero,y,info,trans) - if (info == psb_success_) call inner_vscal1(nar,d,y) - else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,zzero,tmp,info,trans) - - if (info == psb_success_) call inner_vscal1(nar,d,tmp) - if (info == psb_success_) then - inar = nar - call psb_geaxpby(inar,zone,tmp,beta,y,info) - end if - - if (info == psb_success_) then - deallocate(tmp,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return -contains - subroutine inner_vscal(n,d,x,y) - implicit none - integer(psb_lpk_), intent(in) :: n - complex(psb_dpk_), intent(in) :: d(*),x(*) - complex(psb_dpk_), intent(out) :: y(*) - integer(psb_lpk_) :: i - - do i=1,n - y(i) = d(i)*x(i) - end do - end subroutine inner_vscal - - - subroutine inner_vscal1(n,d,x) - implicit none - integer(psb_lpk_), intent(in) :: n - complex(psb_dpk_), intent(in) :: d(*) - complex(psb_dpk_), intent(inout) :: x(*) - integer(psb_lpk_) :: i - - do i=1,n - x(i) = d(i)*x(i) - end do - end subroutine inner_vscal1 - -end subroutine psb_lz_base_cssv - - -subroutine psb_lz_base_scals(d,a,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scals - use psb_error_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_scals' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_scals - - - -subroutine psb_lz_base_scal(d,a,info,side) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scal - use psb_error_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_scal' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_scal - - - -function psb_lz_base_maxval(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_maxval - - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='maxval' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - res = dzero - ! 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()) - - call psb_error_handler(err_act) - -end function psb_lz_base_maxval - - -function psb_lz_base_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnmi - - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnmi' - real(psb_dpk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = dzero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%arwsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_lz_base_csnmi - -function psb_lz_base_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnm1 - - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='csnm1' - real(psb_dpk_), allocatable :: vt(:) - - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - res = dzero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - call a%aclsum(vt) - res = maxval(vt) - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end function psb_lz_base_csnm1 - -subroutine psb_lz_base_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_rowsum - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_rowsum - -subroutine psb_lz_base_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_arwsum - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='arwsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_arwsum - -subroutine psb_lz_base_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_colsum - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_colsum - -subroutine psb_lz_base_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_aclsum - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_aclsum - - -subroutine psb_lz_base_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_get_diag - - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_erractionsave(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()) - - call psb_error_handler(err_act) - -end subroutine psb_lz_base_get_diag - - -! == ================================== -! -! -! -! Computational routines for lz_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! -! -! -! -! == ================================== - - - -subroutine psb_lz_base_vect_mv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_vect_mv - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - ! For the time being we just throw everything back - ! onto the normal routines. - call x%sync() - call y%sync() - call a%spmm(alpha,x%v,beta,y%v,info,trans) - call y%set_host() -end subroutine psb_lz_base_vect_mv - -subroutine psb_lz_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_vect_cssv - use psb_z_base_vect_mod - use psb_error_mod - use psb_string_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - class(psb_z_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_z_base_vect_type), intent(inout),optional :: d - - complex(psb_dpk_), allocatable :: tmp(:) - class(psb_z_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, inar, inc - integer(psb_lpk_) :: nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='lz_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (x%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,nac/)) - goto 9999 - end if - if (y%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,nar/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call x%sync() - call y%sync() - if (present(d)) then - call d%sync() - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (d%get_nrows() < nac) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nac/)) - goto 9999 - end if - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(zone,d%v(1:nac),x,zzero,info) - if (info == psb_success_)& - & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - - else if (psb_toupper(scale_) == 'L') then - if (d%get_nrows() < nar) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/9_psb_lpk_,nar/)) - goto 9999 - end if - - if (beta == zzero) then - call a%inner_spsm(alpha,x,zzero,y,info,trans) - if (info == psb_success_) call y%mlt(d%v(1:nar),info) - - else - allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_)& - & call a%inner_spsm(alpha,x,zzero,tmpv,info,trans) - - if (info == psb_success_) call tmpv%mlt(d%v(1:nar),info) - if (info == psb_success_) then - inar = nar - call y%axpby(inar,zone,tmpv,beta,info) - end if - if (info == psb_success_) then - call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%inner_spsm(alpha,x,beta,y,info,trans) - end if - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_vect_cssv - - -subroutine psb_lz_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_inner_vect_sv - use psb_error_mod - use psb_string_mod - use psb_z_base_vect_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - class(psb_z_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_base_inner_vect_sv' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='inner_spsm') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_inner_vect_sv - - - - -subroutine psb_lz_base_cp_to_icoo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_cp_to_icoo - -subroutine psb_lz_base_cp_from_icoo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - call tmp%cp_from_icoo(b,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_cp_from_icoo - - -subroutine psb_lz_base_cp_to_ifmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_z_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_z_coo_sparse_mat) - call a%cp_to_icoo(b,info) - class default - call a%cp_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_cp_to_ifmt - -subroutine psb_lz_base_cp_from_ifmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - call psb_erractionsave(err_act) - - select type(b) - type is (psb_z_coo_sparse_mat) - call a%cp_from_icoo(b,info) - class default - call b%cp_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to/from coo') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_cp_from_ifmt - - -subroutine psb_lz_base_mv_to_icoo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_icoo' - logical, parameter :: debug=.false. - - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='to coo') - goto 9999 - end if - - call a%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_mv_to_icoo - -subroutine psb_lz_base_mv_from_icoo(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_icoo - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_icoo' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name, a_err='from coo') - goto 9999 - end if - - call b%free() - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_base_mv_from_icoo - - -subroutine psb_lz_base_mv_to_ifmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_ifmt' - logical, parameter :: debug=.false. - type(psb_z_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_z_coo_sparse_mat) - call a%mv_to_icoo(b,info) - class default - call a%mv_to_icoo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - end select - - return - -end subroutine psb_lz_base_mv_to_ifmt - -subroutine psb_lz_base_mv_from_ifmt(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_ifmt - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_lz_base_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_ifmt' - logical, parameter :: debug=.false. - type(psb_lz_coo_sparse_mat) :: tmp - - ! - ! Default implementation - ! - info = psb_success_ - select type(b) - type is (psb_z_coo_sparse_mat) - call a%mv_from_icoo(b,info) - class default - call b%mv_to_lcoo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - end select - return - -end subroutine psb_lz_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_z_lcoo_impl.f90 b/base/serial/impl/psb_z_lcoo_impl.f90 deleted file mode 100644 index 9c512e73..00000000 --- a/base/serial/impl/psb_z_lcoo_impl.f90 +++ /dev/null @@ -1,4127 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! - -subroutine psb_lz_coo_get_diag(a,d,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_diag - use psb_error_mod - use psb_const_mod - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - if (a%is_unit()) then - d(1:mnm) = zone - else - d(1:mnm) = zzero - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_get_diag - - -subroutine psb_lz_coo_scal(d,a,info,side) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scal - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - character :: side_ - logical :: left - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - side_ = 'L' - if (present(side)) then - side_ = psb_toupper(side) - end if - - left = (side_ == 'L') - - if (left) then - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - else - m = a%get_ncols() - if (size(d) < m) then - info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ja(i) - a%val(i) = a%val(i) * d(j) - enddo - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_scal - - -subroutine psb_lz_coo_scals(d,a,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scals - use psb_error_mod - use psb_const_mod - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_scals - - -subroutine psb_lz_coo_reallocate_nz(nz,a) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reallocate_nz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: nz - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='lz_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_reallocate_nz - -subroutine psb_lz_coo_mold(a,b,info) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mold - use psb_error_mod - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='coo_mold' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then - call b%free() - deallocate(b,stat=info) - end if - if (info == 0) allocate(psb_lz_coo_sparse_mat :: b, stat=info) - - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info, name) - goto 9999 - end if - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_mold - -subroutine psb_lz_coo_reinit(a,clear) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reinit - use psb_error_mod - implicit none - - class(psb_lz_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = zzero - call a%set_host() - call a%set_upd() - else - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_reinit - - - -subroutine psb_lz_coo_trim(a) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_trim - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - nz = a%get_nzeros() - if (info == psb_success_) call psb_realloc(nz,a%ia,info) - if (info == psb_success_) call psb_realloc(nz,a%ja,info) - if (info == psb_success_) call psb_realloc(nz,a%val,info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_trim - -subroutine psb_lz_coo_clean_zeros(a, info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_clean_zeros - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: info - ! - integer(psb_lpk_) :: i,j,k, nzin - - info = 0 - nzin = a%get_nzeros() - j = 0 - do i=1, nzin - if (a%val(i) /= zzero) then - j = j + 1 - a%val(j) = a%val(i) - a%ia(j) = a%ia(i) - a%ja(j) = a%ja(i) - end if - end do - call a%set_nzeros(j) - call a%trim() -end subroutine psb_lz_coo_clean_zeros - - - -subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_allocate_mnnz - use psb_error_mod - use psb_realloc_mod - implicit none - integer(psb_lpk_), intent(in) :: m,n - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info - integer(psb_lpk_) :: nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - if (m < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/ione,izero/)) - goto 9999 - endif - if (n < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) - goto 9999 - endif - if (present(nz)) then - nz_ = max(nz,ione) - else - nz_ = max(7*m,7*n,ione) - end if - if (nz_ < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) - goto 9999 - endif - if (info == psb_success_) call psb_realloc(nz_,a%ia,info) - if (info == psb_success_) call psb_realloc(nz_,a%ja,info) - if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(lzero) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - ! An empty matrix is sorted! - call a%set_sorted(.true.) - call a%set_host() - end if - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_allocate_mnnz - - - -subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_print - use psb_string_mod - implicit none - - integer(psb_ipk_), intent(in) :: iout - class(psb_lz_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_coo_print' - logical, parameter :: debug=.false. - - character(len=*), parameter :: datatype='complex' - character(len=80) :: frmtv - integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz - - write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - - if (a%is_dev()) call a%sync() - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - if (present(iv)) nmx = max(nmx,maxval(abs(iv))) - if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) - if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) - ni = floor(log10(1.0*nmx)) + 1 - - if (datatype=='real') then - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - else - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - end if - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - -end subroutine psb_lz_coo_print - - - - -function psb_lz_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_nz_row - implicit none - - class(psb_lz_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_) :: res - integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k - integer(psb_ipk_) :: inza - - if (a%is_dev()) call a%sync() - res = 0 - nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. - inza = nza - ip = psb_bsrch(idx,inza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - -end function psb_lz_coo_get_nz_row - -subroutine psb_lz_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cssm - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_base_csmm' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nc = min(size(x,2) , size(y,2)) - nnz = a%get_nzeros() - - if (alpha == zzero) then - if (beta == zzero) then - do i = 1, m - y(i,1:nc) = zzero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - end if - - if (beta == zzero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),y,size(y,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*y(i,1:nc) - end do - else - allocate(tmp(m,nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & m,nc,nnz,a%ia,a%ja,a%val,& - & x,size(x,1,kind=psb_lpk_),tmp,size(tmp,1,kind=psb_lpk_),info) - do i = 1, m - y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) - end do - end if - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='inner_coosm') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - - -9999 call psb_error_handler(err_act) - - return - - -contains - - subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) - complex(psb_dpk_), intent(in) :: val(*), x(ldx,*) - complex(psb_dpk_), intent(out) :: y(ldy,*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc - complex(psb_dpk_), allocatable :: acc(:) - - info = psb_success_ - allocate(acc(nc), stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - return - end if - - - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = zzero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc(1:nc) = zzero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j + 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = zzero - do - if (j < 1) exit - if (ia(j) < i) exit - acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) - j = j - 1 - end do - y(i,1:nc) = x(i,1:nc) - acc(1:nc) - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc(1:nc) = zzero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) - j = j - 1 - exit - end if - acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) /val(j) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i,1:nc) = x(i,1:nc) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / conjg(val(j)) - j = j - 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i,1:nc) = y(i,1:nc) / conjg(val(j)) - j = j + 1 - end if - acc(1:nc) = y(i,1:nc) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j + 1 - end do - end do - end if - end if - end if - - end if - end subroutine inner_coosm - -end subroutine psb_lz_coo_cssm - - - -subroutine psb_lz_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cssv - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: tmp(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_coo_cssv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - if (a%is_dev()) call a%sync() - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - m = a%get_nrows() - if (size(x,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - if (.not. (a%is_triangle())) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (alpha == zzero) then - if (beta == zzero) then - do i = 1, m - y(i) = zzero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - end if - - if (beta == zzero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,y,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*y(i) - end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& - & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& - & x,tmp,info) - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - do i = 1, m - y(i) = alpha*tmp(i) + beta*y(i) - end do - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none - logical, intent(in) :: tra,ctra,lower,unit,sorted - integer(psb_lpk_), intent(in) :: nr,nz,ia(*),ja(*) - complex(psb_dpk_), intent(in) :: val(*), x(*) - complex(psb_dpk_), intent(out) :: y(*) - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: i,j,k,m, ir, jc, nnz - complex(psb_dpk_) :: acc - - info = psb_success_ - if (.not.sorted) then - info = psb_err_invalid_mat_state_ - return - end if - - nnz = nz - - if ((.not.tra).and.(.not.ctra)) then - - if (lower) then - if (unit) then - j = 1 - do i=1, nr - acc = zzero - do - if (j > nnz) exit - if (ia(j) > i) exit - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - y(i) = x(i) - acc - end do - else if (.not.unit) then - j = 1 - do i=1, nr - acc = zzero - do - if (j > nnz) exit - if (ia(j) > i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j + 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j + 1 - end do - end do - end if - - else if (.not.lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = zzero - do - if (j < 1) exit - if (ia(j) < i) exit - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - y(i) = x(i) - acc - end do - - else if (.not.unit) then - - j = nnz - do i=nr, 1, -1 - acc = zzero - do - if (j < 1) exit - if (ia(j) < i) exit - if (ja(j) == i) then - y(i) = (x(i) - acc)/val(j) - j = j - 1 - exit - end if - acc = acc + val(j)*y(ja(j)) - j = j - 1 - end do - end do - end if - - end if - - else if (tra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /val(j) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j + 1 - end do - end do - end if - end if - end if - - else if (ctra) then - - do i=1, nr - y(i) = x(i) - end do - - if (lower) then - if (unit) then - j = nnz - do i=nr, 1, -1 - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j - 1 - end do - end do - else if (.not.unit) then - j = nnz - do i=nr, 1, -1 - if (ja(j) == i) then - y(i) = y(i) /conjg(val(j)) - j = j - 1 - end if - acc = y(i) - do - if (j < 1) exit - if (ia(j) < i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j - 1 - end do - end do - - else if (.not.lower) then - if (unit) then - j = 1 - do i=1, nr - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j + 1 - end do - end do - else if (.not.unit) then - j = 1 - do i=1, nr - if (ja(j) == i) then - y(i) = y(i) /conjg(val(j)) - j = j + 1 - end if - acc = y(i) - do - if (j > nnz) exit - if (ia(j) > i) exit - jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j + 1 - end do - end do - end if - end if - end if - end if - - end subroutine inner_coosv - - -end subroutine psb_lz_coo_cssv - -subroutine psb_lz_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csmv - implicit none - - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_dpk_) :: acc - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_coo_csmv_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - if (alpha == zzero) then - if (beta == zzero) then - do i = 1, m - y(i) = zzero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - return - else - if (a%is_unit()) then - if (beta == zzero) then - do i = 1, min(m,n) - y(i) = alpha*x(i) - enddo - do i = min(m,n)+1, m - y(i) = zzero - enddo - else - do i = 1, min(m,n) - y(i) = beta*y(i) + alpha*x(i) - end do - do i = min(m,n)+1, m - y(i) = beta*y(i) - enddo - endif - else - if (beta == zzero) then - do i = 1, m - y(i) = zzero - enddo - else - do i = 1, m - y(i) = beta*y(i) - end do - endif - - endif - - end if - - if ((.not.tra).and.(.not.ctra)) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = zzero - do - if (i>nnz) then - y(ir) = y(ir) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir) = y(ir) + alpha * acc - ir = a%ia(i) - acc = zzero - endif - acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == zone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + a%val(i)*x(jc) - enddo - - else if (alpha == -zone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - a%val(i)*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*a%val(i)*x(jc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == zone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + conjg(a%val(i))*x(jc) - enddo - - else if (alpha == -zone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) - conjg(a%val(i))*x(jc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir) = y(ir) + alpha*conjg(a%val(i))*x(jc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_csmv - - -subroutine psb_lz_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csmm - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_), allocatable :: acc(:) - logical :: tra, ctra - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_coo_csmm_impl' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (a%is_dev()) call a%sync() - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - end if - - - tra = (psb_toupper(trans_) == 'T') - ctra = (psb_toupper(trans_) == 'C') - - - if (tra.or.ctra) then - m = a%get_ncols() - n = a%get_nrows() - else - n = a%get_ncols() - m = a%get_nrows() - end if - if (size(x,1) < n) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/3_psb_lpk_,size(x,1,kind=psb_lpk_),n/)) - goto 9999 - end if - if (size(y,1) < m) then - info = psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/5_psb_lpk_,size(y,1,kind=psb_lpk_),m/)) - goto 9999 - end if - - nnz = a%get_nzeros() - - nc = min(size(x,2), size(y,2)) - allocate(acc(nc),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='allocate') - goto 9999 - end if - - - if (alpha == zzero) then - if (beta == zzero) then - do i = 1, m - y(i,1:nc) = zzero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - return - else - if (a%is_unit()) then - if (beta == zzero) then - do i = 1, min(m,n) - y(i,1:nc) = alpha*x(i,1:nc) - enddo - do i = min(m,n)+1, m - y(i,1:nc) = zzero - enddo - else - do i = 1, min(m,n) - y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) - end do - do i = min(m,n)+1, m - y(i,1:nc) = beta*y(i,1:nc) - enddo - endif - else - if (beta == zzero) then - do i = 1, m - y(i,1:nc) = zzero - enddo - else - do i = 1, m - y(i,1:nc) = beta*y(i,1:nc) - end do - endif - - endif - - end if - - if (.not.tra) then - i = 1 - j = i - if (nnz > 0) then - ir = a%ia(1) - acc = zzero - do - if (i>nnz) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - exit - endif - if (a%ia(i) /= ir) then - y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) - acc = zzero - endif - acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 - enddo - end if - - else if (tra) then - - if (alpha == zone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) - enddo - - else if (alpha == -zone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - else if (ctra) then - - if (alpha == zone) then - i = 1 - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + conjg(a%val(i))*x(jc,1:nc) - enddo - - else if (alpha == -zone) then - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) - conjg(a%val(i))*x(jc,1:nc) - enddo - - else - - do i=1,nnz - ir = a%ja(i) - jc = a%ia(i) - y(ir,1:nc) = y(ir,1:nc) + alpha*conjg(a%val(i))*x(jc,1:nc) - enddo - - end if !.....end testing on alpha - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_csmm - -function psb_lz_coo_maxval(a) result(res) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_maxval - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_ipk_) :: info - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - character(len=20) :: name='lz_coo_maxval' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - res = done - else - res = dzero - end if - nnz = a%get_nzeros() - if (allocated(a%val)) then - nnz = min(nnz,size(a%val)) - res = maxval(abs(a%val(1:nnz))) - end if - -end function psb_lz_coo_maxval - -function psb_lz_coo_csnmi(a) result(res) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnmi - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra, is_unit - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='lz_coo_csnmi' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = dzero - nnz = a%get_nzeros() - is_unit = a%is_unit() - if (a%is_by_rows()) 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 - if (is_unit) then - acc = done - else - acc = dzero - end if - 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 - if (is_unit) then - vt = done - else - vt = dzero - end if - do j=1, nnz - i = a%ia(j) - vt(i) = vt(i) + abs(a%val(j)) - end do - res = maxval(vt(1:m)) - deallocate(vt,stat=info) - end if - -end function psb_lz_coo_csnmi - - -function psb_lz_coo_csnm1(a) result(res) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnm1 - - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='lz_coo_csnm1' - logical, parameter :: debug=.false. - - if (a%is_dev()) call a%sync() - - res = dzero - nnz = a%get_nzeros() - n = a%get_ncols() - allocate(vt(n),stat=info) - if (info /= 0) return - if (a%is_unit()) then - vt = done - else - vt = dzero - end if - 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) - - return - -end function psb_lz_coo_csnm1 - -subroutine psb_lz_coo_rowsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_rowsum - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = zone - else - d = zzero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_rowsum - -subroutine psb_lz_coo_arwsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_arwsum - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='rowsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - m = a%get_nrows() - if (size(d) < m) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),m/)) - goto 9999 - end if - - if (a%is_unit()) then - d = done - else - d = dzero - end if - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_arwsum - -subroutine psb_lz_coo_colsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_colsum - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='colsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - if (a%is_unit()) then - d = zone - else - d = zzero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_colsum - -subroutine psb_lz_coo_aclsum(d,a) - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_aclsum - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - - integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='aclsum' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - n = a%get_ncols() - if (size(d) < n) then - info=psb_err_input_asize_small_i_ - call psb_errpush(info,name,l_err=(/1_psb_lpk_,size(d,kind=psb_lpk_),n/)) - goto 9999 - end if - - - if (a%is_unit()) then - d = done - else - d = dzero - end if - - 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 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_aclsum - - - -! == ================================== -! -! -! -! Data management -! -! -! -! -! -! == ================================== - - - -subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csgetptn - implicit none - - class(psb_lz_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = iren(a%ia(i)) - ja(nzin_) = iren(a%ja(i)) - end if - enddo - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nzin_ = nzin_ + 1 - nz = nz + 1 - ia(nzin_) = a%ia(i) - ja(nzin_) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - end if - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= psb_success_) return - - end if - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - nzin_=nzin_+k - end if - nz = k - end if - - end subroutine coo_getptn - -end subroutine psb_lz_coo_csgetptn - - -! -! NZ is the number of non-zeros on output. -! The output is guaranteed to be sorted -! -subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csgetrow - implicit none - - class(psb_lz_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: imin,imax - integer(psb_lpk_), intent(out) :: nz - integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_lpk_), intent(in), optional :: iren(:) - integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - logical :: append_, rscale_, cscale_ - integer(psb_lpk_) :: nzin_, jmin_, jmax_, i - integer(psb_ipk_) :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - info = psb_success_ - nz = 0 - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - endif - - if ((imax= psb_debug_serial_)& - & write(debug_unit,*) trim(name), ': srtdcoo ' - do - ip = psb_bsrch(irw,inza,a%ia) - if (ip /= -1) exit - irw = irw + 1 - if (irw > imax) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,imin - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_bsrch(lrw,inza,a%ia) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nzt = jp - ip +1 - nz = 0 - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = iren(a%ia(i)) - ja(nzin_+nz) = iren(a%ja(i)) - end if - enddo - call psb_lz_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - else - do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - nz = nz + 1 - val(nzin_+nz) = a%val(i) - ia(nzin_+nz) = a%ia(i) - ja(nzin_+nz) = a%ja(i) - end if - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - - nrd = max(a%get_nrows(),1) - nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - if (present(iren)) then - k = 0 - do i=1, a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = iren(a%ia(i)) - ja(nzin_+k) = iren(a%ja(i)) - endif - enddo - else - k = 0 - do i=1,a%get_nzeros() - if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 - if (k > nzt) then - nzt = k + nzt - call psb_ensure_size(nzin_+nzt,ia,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= psb_success_) return - - end if - val(nzin_+k) = a%val(i) - ia(nzin_+k) = (a%ia(i)) - ja(nzin_+k) = (a%ja(i)) - endif - enddo - end if - call psb_lz_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ - end if - - end subroutine coo_getrow - -end subroutine psb_lz_coo_csgetrow - - -subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csput_a - implicit none - - class(psb_lz_coo_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - - - integer(psb_ipk_) :: err_act - character(len=20) :: name='lz_coo_csput_a_impl' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: nza, i,j,k, nzl, isza - integer(psb_ipk_) :: debug_level, debug_unit - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (nz < 0) then - info = psb_err_iarg_neg_ - call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) - goto 9999 - end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) - goto 9999 - end if - - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) - goto 9999 - end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) - goto 9999 - end if - - if (nz == 0) return - - - nza = a%get_nzeros() - isza = a%get_size() - if (a%is_bld()) then - ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then - call a%reallocate(max(nza+nz,int(1.5*isza))) - endif - isza = a%get_size() - if (isza < (nza+nz)) then - info = psb_err_alloc_dealloc_; call psb_errpush(info,name) - goto 9999 - end if - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& - & imin,imax,jmin,jmax,info,gtl) - call a%set_nzeros(nza) - call a%set_sorted(.false.) - - - else if (a%is_upd()) then - - if (a%is_dev()) call a%sync() - - call lz_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - if (info < 0) then - info = psb_err_internal_error_ - else if (info > 0) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' - info = psb_success_ - end if - else - ! State is wrong. - info = psb_err_invalid_mat_state_ - end if - if (info /= psb_success_) then - call psb_errpush(info,name) - goto 9999 - end if - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl) - implicit none - - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) - complex(psb_dpk_), intent(in) :: val(:) - complex(psb_dpk_), intent(inout) :: aspk(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic,ng - - info = psb_success_ - if (present(gtl)) then - ng = size(gtl) - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - - - subroutine lz_coo_srch_upd(nz,ia,ja,val,a,& - & imin,imax,jmin,jmax,info,gtl) - - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - implicit none - - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_lpk_), intent(in) :: ia(:),ja(:) - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), intent(in), optional :: gtl(:) - integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nnz,dupl,ng, nr - integer(psb_ipk_) :: debug_level, debug_unit, innz, nc - character(len=20) :: name='lz_coo_srch_upd' - - info = psb_success_ - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - dupl = a%get_dupl() - - if (.not.a%is_sorted()) then - info = -4 - return - end if - - ilr = -1 - ilc = -1 - nnz = a%get_nzeros() - nr = a%get_nrows() - innz = nnz - - if (present(gtl)) then - ng = size(gtl) - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= nr)) then - ic = gtl(ic) - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - endif - else - info = max(info,1) - end if - end do - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - else - info = max(info,1) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then - - if (ir /= ilr) then - i1 = psb_bsrch(ir,innz,a%ia) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia(i2+1) /= a%ia(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia(i1-1) /= a%ia(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then - a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) - else - info = max(info,3) - end if - else - info = max(info,2) - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - end if - - end subroutine lz_coo_srch_upd - -end subroutine psb_lz_coo_csput_a - - -subroutine psb_lz_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_coo - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_cp_coo_to_coo - -subroutine psb_lz_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_coo - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - class(psb_lz_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_cp_coo_from_coo - - -subroutine psb_lz_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_fmt - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - class(psb_lz_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_cp_coo_to_fmt - -subroutine psb_lz_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_fmt - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - class(psb_lz_base_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%cp_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_cp_coo_from_fmt - - -subroutine psb_lz_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_coo - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat - call b%set_sort_status(a%get_sort_status()) - call b%set_nzeros(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call b%set_host() - call a%free() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_mv_coo_to_coo - -subroutine psb_lz_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_coo - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - class(psb_lz_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - call a%set_nzeros(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_mv_coo_from_coo - - -subroutine psb_lz_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_fmt - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - class(psb_lz_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_from_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_mv_coo_to_fmt - -subroutine psb_lz_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_fmt - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - class(psb_lz_base_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - - call psb_erractionsave(err_act) - info = psb_success_ - - call b%mv_to_coo(a,info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_mv_coo_from_fmt - -subroutine psb_lz_coo_cp_from(a,b) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cp_from - implicit none - - class(psb_lz_coo_sparse_mat), intent(inout) :: a - type(psb_lz_coo_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%cp_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_cp_from - -subroutine psb_lz_coo_mv_from(a,b) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mv_from - implicit none - - class(psb_lz_coo_sparse_mat), intent(inout) :: a - type(psb_lz_coo_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%mv_from_coo(b,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_coo_mv_from - - - -subroutine psb_lz_fix_coo(a,info,idir) - use psb_const_mod - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo - implicit none - - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - integer(psb_lpk_), allocatable :: iaux(:) - !locals - integer(psb_lpk_) :: nza, nzl,iret, nra, nca - integer(psb_lpk_) :: i,j, irw, icl - integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ - character(len=20) :: name = 'psb_fixcoo' - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia),size(a%ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - if (a%is_dev()) call a%sync() - - nra = a%get_nrows() - nca = a%get_ncols() - nza = a%get_nzeros() - if (nza >= 2) then - dupl_ = a%get_dupl() - call psb_lz_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= psb_success_) goto 9999 - else - i = nza - end if - call a%set_sort_status(idir_) - call a%set_nzeros(i) - call a%set_asb() - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_fix_coo - - - -subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo_inner - use psb_string_mod - use psb_ip_reord_mod - use psb_sort_mod - implicit none - - integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl - integer(psb_lpk_), intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), intent(inout) :: val(:) - integer(psb_lpk_), intent(out) :: nzout - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: idir - !locals - integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) - complex(psb_dpk_), allocatable :: vs(:) - integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin - integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - logical :: srt_inp, use_buffers - - info = psb_success_ - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(ia),size(ja) - if (present(idir)) then - idir_ = idir - else - idir_ = psb_row_major_ - endif - - - if (nzin < 2) then - call psb_erractionrestore(err_act) - return - end if - - dupl_ = dupl - - - - allocate(iaux(max(nr,nc,nzin)+2),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) - use_buffers = (info == 0) - - select case(idir_) - - case(psb_row_major_) - ! Row major order - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then - iaux(:) = 0 - iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ia(i)) = iaux(ia(i)) + 1 - srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) - end do - else - use_buffers=.false. - end if - end if - ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major - ! we can do it row-by-row here. - k = 0 - i = 1 - do j=1, nr - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ja(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already row-major - ! we have to sort all - - ip = iaux(1) - iaux(1) = 0 - do i=2, nr - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nr+1) = ip - - do i=1,nzin - irw = ia(i) - ip = iaux(irw) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(irw) = ip - end do - k = 0 - i = 1 - do j=1, nr - - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,jas(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - ! - ! If we did not have enough memory for buffers, - ! let's try in place. - ! - inzin = nzin - call psi_msort_up(inzin,ia(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - - do while ((ia(j) == ia(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ja(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - endif - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - - case(psb_col_major_) - - if (use_buffers) then - iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then - iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. - do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then - use_buffers = .false. - srt_inp = .false. - exit - end if - iaux(ja(i)) = iaux(ja(i)) + 1 - srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) - end do - else - use_buffers=.false. - end if - end if - !use_buffers=use_buffers.and.srt_inp - ! Check again use_buffers. - if (use_buffers) then - - if (srt_inp) then - ! If input was already col-major - ! we can do it col-by-col here. - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j) - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ia(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:imx),& - & ia(i:imx),ja(i:imx),ix2) - - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - val(k) = val(k) + val(i) - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = val(i) - ia(k) = ia(i) - ja(k) = ja(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - !i = i + nzl - enddo - - else if (.not.srt_inp) then - ! If input was not already col-major - ! we have to sort all - ip = iaux(1) - iaux(1) = 0 - do i=2, nc - is = iaux(i) - iaux(i) = ip - ip = ip + is - end do - iaux(nc+1) = ip - - do i=1,nzin - icl = ja(i) - ip = iaux(icl) + 1 - ias(ip) = ia(i) - jas(ip) = ja(i) - vs(ip) = val(i) - iaux(icl) = ip - end do - k = 0 - i = 1 - do j=1, nc - nzl = iaux(j)-i+1 - imx = i+nzl-1 - - if (nzl > 0) then - call psi_msort_up(nzl,ias(i:imx),ix2,iret) - if (iret == 0) & - & call psb_ip_reord(nzl,vs(i:imx),& - & ias(i:imx),jas(i:imx),ix2) - select case(dupl_) - case(psb_dupl_ovwrt_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_add_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - val(k) = val(k) + vs(i) - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - - case(psb_dupl_err_) - k = k + 1 - ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) - do - i = i + 1 - if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - k = k+1 - val(k) = vs(i) - ia(k) = ias(i) - ja(k) = jas(i) - irw = ia(k) - icl = ja(k) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - return - end select - - endif - enddo - - end if - - i=k - deallocate(ias,jas,vs,ix2, stat=info) - - else if (.not.use_buffers) then - - inzin = nzin - call psi_msort_up(inzin,ja(1:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(inzin,val,ia,ja,iaux) - i = 1 - j = i - do while (i <= nzin) - do while ((ja(j) == ja(i))) - j = j+1 - if (j > nzin) exit - enddo - nzl = j - i - call psi_msort_up(nzl,ia(i:),iaux(1:),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,val(i:i+nzl-1),& - & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = ia(i) - icl = ja(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - val(i) = val(i) + val(j) - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) - goto 9999 - else - i = i+1 - val(i) = val(j) - ia(i) = ia(j) - ja(i) = ja(j) - irw = ia(i) - icl = ja(i) - endif - enddo - case default - write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ - info =-7 - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - end if - - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 - end select - - nzout = i - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_fix_coo_inner - - -subroutine psb_lz_cp_coo_to_icoo(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_icoo - implicit none - class(psb_lz_coo_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: nz - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = psb_success_ - if (a%is_dev()) call a%sync() - - b%psb_base_sparse_mat = a%psb_lbase_sparse_mat - call b%set_sort_status(a%get_sort_status()) - nz = a%get_nzeros() - call b%set_nzeros(nz) - call b%reallocate(nz) - - b%ia(1:nz) = a%ia(1:nz) - b%ja(1:nz) = a%ja(1:nz) - b%val(1:nz) = a%val(1:nz) - - call b%set_host() - - if (.not.b%is_by_rows()) call b%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_cp_coo_to_icoo - -subroutine psb_lz_cp_coo_from_icoo(a,b,info) - use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_icoo - implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer(psb_lpk_) :: m,n,nz - - call psb_erractionsave(err_act) - info = psb_success_ - if (b%is_dev()) call b%sync() - a%psb_lbase_sparse_mat = b%psb_base_sparse_mat - call a%set_sort_status(b%get_sort_status()) - nz = b%get_nzeros() - call a%set_nzeros(nz) - call a%reallocate(nz) - - a%ia(1:nz) = b%ia(1:nz) - a%ja(1:nz) = b%ja(1:nz) - a%val(1:nz) = b%val(1:nz) - - call a%set_host() - - if (.not.a%is_by_rows()) call a%fix(info) - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - - call psb_error_handler(err_act) - - return - -end subroutine psb_lz_cp_coo_from_icoo -