[ADD] Generate the nested matrix support for s/c/z from the templates
Extend the nested (MATNEST) matrix support to all the arithmetics: the
psb_{s,c,z}_nest_{mat,base_mat,tools,builder}_mod modules and the
psb_{s,c,z}_nest_mod umbrellas are generated from the template-psblas
X_nest_* templates; the d sources are regenerated byte-identical.
Preparatory changes to the d sources for clean templating: rowsum/arwsum and
colsum/aclsum no longer share a helper (for the complex arithmetics the
absolute sums are real-valued while the plain sums are complex-valued), the
transposed kernel forwards the actual 'T'/'C' character to the blocks
(conjugate transpose for the complex types), and the capacity helper takes a
type-neutral name.
Build hooks (autotools Makefile and CMakeLists) updated with the per-arith
objects, compile rules and dependencies. All four d tests keep passing.
Author: Simone Staccone (Stack-1)
nested_matrix_type
Stack-1
1 month ago
parent
fd60bb8d7f
commit
e1d759d019
@ -0,0 +1,49 @@
|
||||
!
|
||||
! 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_c_nest_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Umbrella module for the nested (block-structured) double precision
|
||||
! real types. Users need only:
|
||||
!
|
||||
! use psb_c_nest_mod
|
||||
!
|
||||
! to access all three container types and their parallel operations.
|
||||
!
|
||||
module psb_c_nest_mod
|
||||
use psb_desc_nest_mod ! grid descriptor (per-field, input to compose)
|
||||
use psb_c_nest_mat_mod ! block storage (psb_c_nest_sparse_mat)
|
||||
use psb_c_nest_base_mat_mod ! MATNEST operator + field-split interface
|
||||
use psb_cd_nest_tools_mod ! psb_cd_nest_compose (global descriptor)
|
||||
use psb_c_nest_tools_mod ! block assembly + psb_c_nest_rect_block
|
||||
use psb_c_nest_builder_mod ! psb_c_nest_matrix: init/ins/asb frontend
|
||||
end module psb_c_nest_mod
|
||||
@ -0,0 +1,49 @@
|
||||
!
|
||||
! 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_s_nest_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Umbrella module for the nested (block-structured) double precision
|
||||
! real types. Users need only:
|
||||
!
|
||||
! use psb_s_nest_mod
|
||||
!
|
||||
! to access all three container types and their parallel operations.
|
||||
!
|
||||
module psb_s_nest_mod
|
||||
use psb_desc_nest_mod ! grid descriptor (per-field, input to compose)
|
||||
use psb_s_nest_mat_mod ! block storage (psb_s_nest_sparse_mat)
|
||||
use psb_s_nest_base_mat_mod ! MATNEST operator + field-split interface
|
||||
use psb_cd_nest_tools_mod ! psb_cd_nest_compose (global descriptor)
|
||||
use psb_s_nest_tools_mod ! block assembly + psb_s_nest_rect_block
|
||||
use psb_s_nest_builder_mod ! psb_s_nest_matrix: init/ins/asb frontend
|
||||
end module psb_s_nest_mod
|
||||
@ -0,0 +1,49 @@
|
||||
!
|
||||
! 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_z_nest_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Umbrella module for the nested (block-structured) double precision
|
||||
! real types. Users need only:
|
||||
!
|
||||
! use psb_z_nest_mod
|
||||
!
|
||||
! to access all three container types and their parallel operations.
|
||||
!
|
||||
module psb_z_nest_mod
|
||||
use psb_desc_nest_mod ! grid descriptor (per-field, input to compose)
|
||||
use psb_z_nest_mat_mod ! block storage (psb_z_nest_sparse_mat)
|
||||
use psb_z_nest_base_mat_mod ! MATNEST operator + field-split interface
|
||||
use psb_cd_nest_tools_mod ! psb_cd_nest_compose (global descriptor)
|
||||
use psb_z_nest_tools_mod ! block assembly + psb_z_nest_rect_block
|
||||
use psb_z_nest_builder_mod ! psb_z_nest_matrix: init/ins/asb frontend
|
||||
end module psb_z_nest_mod
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,149 @@
|
||||
!
|
||||
! 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 without 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_c_nest_mat_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Defines psb_c_nest_sparse_mat: a block-structured distributed sparse
|
||||
! matrix for double precision real arithmetic.
|
||||
!
|
||||
! The matrix is stored as a 2-D array of psb_cspmat_type sub-matrices.
|
||||
! Block presence is determined directly from the sub-matrix storage: a block
|
||||
! (i,j) is present iff mats(i,j)%a is allocated (absent blocks contribute zero
|
||||
! to any product). There is no separate presence flag array.
|
||||
!
|
||||
! Descriptor convention (current nested design)
|
||||
! ---------------------------------------------
|
||||
! Each matrix block (i,j) is associated with descs(i,j) from the
|
||||
! corresponding psb_desc_nest_type. Nested tools (psb_spall_nest,
|
||||
! psb_spins_nest, psb_spasb_nest, psb_spmm) consistently pass
|
||||
! descs(i,j) together with mats(i,j).
|
||||
!
|
||||
! A block may be structurally absent (NULL/zero): this is represented by
|
||||
! mats(i,j) left unbuilt (mats(i,j)%a not allocated). In that case the
|
||||
! block contributes zero and is skipped by nested kernels.
|
||||
!
|
||||
! Descriptor storage is distinct from matrix presence: descriptors are
|
||||
! typically defined for all block positions in descs(:,:), while actual
|
||||
! matrix blocks may be present only on a subset.
|
||||
!
|
||||
! Reference examples in test/pdegen:
|
||||
! * psb_c_pde_nest.full.F90 (A(2,2) left NULL, mats(2,2)%a not allocated)
|
||||
! * psb_c_nest_tools.F90 and psb_c_pde_nest_full_tools.F90
|
||||
! (2-D desc_nest%descs(i,j) used in nested allocation/assembly).
|
||||
!
|
||||
module psb_c_nest_mat_mod
|
||||
use psb_c_mat_mod
|
||||
implicit none
|
||||
|
||||
type :: psb_c_nest_sparse_mat
|
||||
integer(psb_ipk_) :: nrblocks = 0
|
||||
integer(psb_ipk_) :: ncblocks = 0
|
||||
type(psb_cspmat_type), allocatable :: mats(:,:)
|
||||
contains
|
||||
procedure :: get_nrblocks => psb_c_nest_mat_get_nrb
|
||||
procedure :: get_ncblocks => psb_c_nest_mat_get_ncb
|
||||
procedure :: has_block => psb_c_nest_mat_has_block
|
||||
procedure :: sizeof => psb_c_nest_mat_sizeof
|
||||
procedure :: free => psb_c_nest_mat_free
|
||||
end type psb_c_nest_sparse_mat
|
||||
|
||||
contains
|
||||
|
||||
! get_nrblocks / get_ncblocks
|
||||
function psb_c_nest_mat_get_nrb(a) result(n)
|
||||
class(psb_c_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_) :: n
|
||||
n = a%nrblocks
|
||||
end function psb_c_nest_mat_get_nrb
|
||||
|
||||
function psb_c_nest_mat_get_ncb(a) result(n)
|
||||
class(psb_c_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_) :: n
|
||||
n = a%ncblocks
|
||||
end function psb_c_nest_mat_get_ncb
|
||||
|
||||
! has_block: return .true. if block (i,j) is non-null
|
||||
function psb_c_nest_mat_has_block(a, i_block_row, j_block_col) result(has)
|
||||
class(psb_c_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_), intent(in) :: i_block_row, j_block_col
|
||||
logical :: has
|
||||
|
||||
has = .false.
|
||||
if (i_block_row < 1 .or. i_block_row > a%nrblocks) return
|
||||
if (j_block_col < 1 .or. j_block_col > a%ncblocks) return
|
||||
if (.not. allocated(a%mats)) return
|
||||
! P3: presence is determined solely by whether the sub-matrix has been
|
||||
! built (its polymorphic storage %a is allocated). No parallel flag array.
|
||||
has = allocated(a%mats(i_block_row, j_block_col)%a)
|
||||
end function psb_c_nest_mat_has_block
|
||||
|
||||
! sizeof: total storage across all allocated sub-matrices
|
||||
function psb_c_nest_mat_sizeof(a) result(total_bytes)
|
||||
class(psb_c_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_epk_) :: total_bytes
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col
|
||||
|
||||
total_bytes = 0_psb_epk_
|
||||
if (allocated(a%mats)) then
|
||||
do j_block_col = 1, a%ncblocks
|
||||
do i_block_row = 1, a%nrblocks
|
||||
if (allocated(a%mats(i_block_row, j_block_col)%a)) &
|
||||
& total_bytes = total_bytes + a%mats(i_block_row, j_block_col)%sizeof()
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
end function psb_c_nest_mat_sizeof
|
||||
|
||||
! free: release all sub-matrices
|
||||
subroutine psb_c_nest_mat_free(a, info)
|
||||
class(psb_c_nest_sparse_mat), intent(inout) :: a
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
|
||||
info = 0
|
||||
if (allocated(a%mats)) then
|
||||
do j_block_col = 1, a%ncblocks
|
||||
do i_block_row = 1, a%nrblocks
|
||||
if (allocated(a%mats(i_block_row, j_block_col)%a)) then
|
||||
call a%mats(i_block_row, j_block_col)%free()
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
deallocate(a%mats, stat=local_info)
|
||||
if (local_info /= 0 .and. info == 0) info = local_info
|
||||
end if
|
||||
a%nrblocks = 0
|
||||
a%ncblocks = 0
|
||||
end subroutine psb_c_nest_mat_free
|
||||
|
||||
end module psb_c_nest_mat_mod
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,149 @@
|
||||
!
|
||||
! 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 without 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_s_nest_mat_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Defines psb_s_nest_sparse_mat: a block-structured distributed sparse
|
||||
! matrix for double precision real arithmetic.
|
||||
!
|
||||
! The matrix is stored as a 2-D array of psb_sspmat_type sub-matrices.
|
||||
! Block presence is determined directly from the sub-matrix storage: a block
|
||||
! (i,j) is present iff mats(i,j)%a is allocated (absent blocks contribute zero
|
||||
! to any product). There is no separate presence flag array.
|
||||
!
|
||||
! Descriptor convention (current nested design)
|
||||
! ---------------------------------------------
|
||||
! Each matrix block (i,j) is associated with descs(i,j) from the
|
||||
! corresponding psb_desc_nest_type. Nested tools (psb_spall_nest,
|
||||
! psb_spins_nest, psb_spasb_nest, psb_spmm) consistently pass
|
||||
! descs(i,j) together with mats(i,j).
|
||||
!
|
||||
! A block may be structurally absent (NULL/zero): this is represented by
|
||||
! mats(i,j) left unbuilt (mats(i,j)%a not allocated). In that case the
|
||||
! block contributes zero and is skipped by nested kernels.
|
||||
!
|
||||
! Descriptor storage is distinct from matrix presence: descriptors are
|
||||
! typically defined for all block positions in descs(:,:), while actual
|
||||
! matrix blocks may be present only on a subset.
|
||||
!
|
||||
! Reference examples in test/pdegen:
|
||||
! * psb_s_pde_nest.full.F90 (A(2,2) left NULL, mats(2,2)%a not allocated)
|
||||
! * psb_s_nest_tools.F90 and psb_s_pde_nest_full_tools.F90
|
||||
! (2-D desc_nest%descs(i,j) used in nested allocation/assembly).
|
||||
!
|
||||
module psb_s_nest_mat_mod
|
||||
use psb_s_mat_mod
|
||||
implicit none
|
||||
|
||||
type :: psb_s_nest_sparse_mat
|
||||
integer(psb_ipk_) :: nrblocks = 0
|
||||
integer(psb_ipk_) :: ncblocks = 0
|
||||
type(psb_sspmat_type), allocatable :: mats(:,:)
|
||||
contains
|
||||
procedure :: get_nrblocks => psb_s_nest_mat_get_nrb
|
||||
procedure :: get_ncblocks => psb_s_nest_mat_get_ncb
|
||||
procedure :: has_block => psb_s_nest_mat_has_block
|
||||
procedure :: sizeof => psb_s_nest_mat_sizeof
|
||||
procedure :: free => psb_s_nest_mat_free
|
||||
end type psb_s_nest_sparse_mat
|
||||
|
||||
contains
|
||||
|
||||
! get_nrblocks / get_ncblocks
|
||||
function psb_s_nest_mat_get_nrb(a) result(n)
|
||||
class(psb_s_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_) :: n
|
||||
n = a%nrblocks
|
||||
end function psb_s_nest_mat_get_nrb
|
||||
|
||||
function psb_s_nest_mat_get_ncb(a) result(n)
|
||||
class(psb_s_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_) :: n
|
||||
n = a%ncblocks
|
||||
end function psb_s_nest_mat_get_ncb
|
||||
|
||||
! has_block: return .true. if block (i,j) is non-null
|
||||
function psb_s_nest_mat_has_block(a, i_block_row, j_block_col) result(has)
|
||||
class(psb_s_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_), intent(in) :: i_block_row, j_block_col
|
||||
logical :: has
|
||||
|
||||
has = .false.
|
||||
if (i_block_row < 1 .or. i_block_row > a%nrblocks) return
|
||||
if (j_block_col < 1 .or. j_block_col > a%ncblocks) return
|
||||
if (.not. allocated(a%mats)) return
|
||||
! P3: presence is determined solely by whether the sub-matrix has been
|
||||
! built (its polymorphic storage %a is allocated). No parallel flag array.
|
||||
has = allocated(a%mats(i_block_row, j_block_col)%a)
|
||||
end function psb_s_nest_mat_has_block
|
||||
|
||||
! sizeof: total storage across all allocated sub-matrices
|
||||
function psb_s_nest_mat_sizeof(a) result(total_bytes)
|
||||
class(psb_s_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_epk_) :: total_bytes
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col
|
||||
|
||||
total_bytes = 0_psb_epk_
|
||||
if (allocated(a%mats)) then
|
||||
do j_block_col = 1, a%ncblocks
|
||||
do i_block_row = 1, a%nrblocks
|
||||
if (allocated(a%mats(i_block_row, j_block_col)%a)) &
|
||||
& total_bytes = total_bytes + a%mats(i_block_row, j_block_col)%sizeof()
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
end function psb_s_nest_mat_sizeof
|
||||
|
||||
! free: release all sub-matrices
|
||||
subroutine psb_s_nest_mat_free(a, info)
|
||||
class(psb_s_nest_sparse_mat), intent(inout) :: a
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
|
||||
info = 0
|
||||
if (allocated(a%mats)) then
|
||||
do j_block_col = 1, a%ncblocks
|
||||
do i_block_row = 1, a%nrblocks
|
||||
if (allocated(a%mats(i_block_row, j_block_col)%a)) then
|
||||
call a%mats(i_block_row, j_block_col)%free()
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
deallocate(a%mats, stat=local_info)
|
||||
if (local_info /= 0 .and. info == 0) info = local_info
|
||||
end if
|
||||
a%nrblocks = 0
|
||||
a%ncblocks = 0
|
||||
end subroutine psb_s_nest_mat_free
|
||||
|
||||
end module psb_s_nest_mat_mod
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,149 @@
|
||||
!
|
||||
! 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 without 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_z_nest_mat_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Defines psb_z_nest_sparse_mat: a block-structured distributed sparse
|
||||
! matrix for double precision real arithmetic.
|
||||
!
|
||||
! The matrix is stored as a 2-D array of psb_zspmat_type sub-matrices.
|
||||
! Block presence is determined directly from the sub-matrix storage: a block
|
||||
! (i,j) is present iff mats(i,j)%a is allocated (absent blocks contribute zero
|
||||
! to any product). There is no separate presence flag array.
|
||||
!
|
||||
! Descriptor convention (current nested design)
|
||||
! ---------------------------------------------
|
||||
! Each matrix block (i,j) is associated with descs(i,j) from the
|
||||
! corresponding psb_desc_nest_type. Nested tools (psb_spall_nest,
|
||||
! psb_spins_nest, psb_spasb_nest, psb_spmm) consistently pass
|
||||
! descs(i,j) together with mats(i,j).
|
||||
!
|
||||
! A block may be structurally absent (NULL/zero): this is represented by
|
||||
! mats(i,j) left unbuilt (mats(i,j)%a not allocated). In that case the
|
||||
! block contributes zero and is skipped by nested kernels.
|
||||
!
|
||||
! Descriptor storage is distinct from matrix presence: descriptors are
|
||||
! typically defined for all block positions in descs(:,:), while actual
|
||||
! matrix blocks may be present only on a subset.
|
||||
!
|
||||
! Reference examples in test/pdegen:
|
||||
! * psb_z_pde_nest.full.F90 (A(2,2) left NULL, mats(2,2)%a not allocated)
|
||||
! * psb_z_nest_tools.F90 and psb_z_pde_nest_full_tools.F90
|
||||
! (2-D desc_nest%descs(i,j) used in nested allocation/assembly).
|
||||
!
|
||||
module psb_z_nest_mat_mod
|
||||
use psb_z_mat_mod
|
||||
implicit none
|
||||
|
||||
type :: psb_z_nest_sparse_mat
|
||||
integer(psb_ipk_) :: nrblocks = 0
|
||||
integer(psb_ipk_) :: ncblocks = 0
|
||||
type(psb_zspmat_type), allocatable :: mats(:,:)
|
||||
contains
|
||||
procedure :: get_nrblocks => psb_z_nest_mat_get_nrb
|
||||
procedure :: get_ncblocks => psb_z_nest_mat_get_ncb
|
||||
procedure :: has_block => psb_z_nest_mat_has_block
|
||||
procedure :: sizeof => psb_z_nest_mat_sizeof
|
||||
procedure :: free => psb_z_nest_mat_free
|
||||
end type psb_z_nest_sparse_mat
|
||||
|
||||
contains
|
||||
|
||||
! get_nrblocks / get_ncblocks
|
||||
function psb_z_nest_mat_get_nrb(a) result(n)
|
||||
class(psb_z_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_) :: n
|
||||
n = a%nrblocks
|
||||
end function psb_z_nest_mat_get_nrb
|
||||
|
||||
function psb_z_nest_mat_get_ncb(a) result(n)
|
||||
class(psb_z_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_) :: n
|
||||
n = a%ncblocks
|
||||
end function psb_z_nest_mat_get_ncb
|
||||
|
||||
! has_block: return .true. if block (i,j) is non-null
|
||||
function psb_z_nest_mat_has_block(a, i_block_row, j_block_col) result(has)
|
||||
class(psb_z_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_ipk_), intent(in) :: i_block_row, j_block_col
|
||||
logical :: has
|
||||
|
||||
has = .false.
|
||||
if (i_block_row < 1 .or. i_block_row > a%nrblocks) return
|
||||
if (j_block_col < 1 .or. j_block_col > a%ncblocks) return
|
||||
if (.not. allocated(a%mats)) return
|
||||
! P3: presence is determined solely by whether the sub-matrix has been
|
||||
! built (its polymorphic storage %a is allocated). No parallel flag array.
|
||||
has = allocated(a%mats(i_block_row, j_block_col)%a)
|
||||
end function psb_z_nest_mat_has_block
|
||||
|
||||
! sizeof: total storage across all allocated sub-matrices
|
||||
function psb_z_nest_mat_sizeof(a) result(total_bytes)
|
||||
class(psb_z_nest_sparse_mat), intent(in) :: a
|
||||
integer(psb_epk_) :: total_bytes
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col
|
||||
|
||||
total_bytes = 0_psb_epk_
|
||||
if (allocated(a%mats)) then
|
||||
do j_block_col = 1, a%ncblocks
|
||||
do i_block_row = 1, a%nrblocks
|
||||
if (allocated(a%mats(i_block_row, j_block_col)%a)) &
|
||||
& total_bytes = total_bytes + a%mats(i_block_row, j_block_col)%sizeof()
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
end function psb_z_nest_mat_sizeof
|
||||
|
||||
! free: release all sub-matrices
|
||||
subroutine psb_z_nest_mat_free(a, info)
|
||||
class(psb_z_nest_sparse_mat), intent(inout) :: a
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
|
||||
info = 0
|
||||
if (allocated(a%mats)) then
|
||||
do j_block_col = 1, a%ncblocks
|
||||
do i_block_row = 1, a%nrblocks
|
||||
if (allocated(a%mats(i_block_row, j_block_col)%a)) then
|
||||
call a%mats(i_block_row, j_block_col)%free()
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
deallocate(a%mats, stat=local_info)
|
||||
if (local_info /= 0 .and. info == 0) info = local_info
|
||||
end if
|
||||
a%nrblocks = 0
|
||||
a%ncblocks = 0
|
||||
end subroutine psb_z_nest_mat_free
|
||||
|
||||
end module psb_z_nest_mat_mod
|
||||
@ -0,0 +1,414 @@
|
||||
!
|
||||
! 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 prior written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: psb_c_nest_builder_mod.F90
|
||||
!
|
||||
! Module: psb_c_nest_builder_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! User-friendly frontend to build a nested (MATNEST) operator without manually
|
||||
! managing per-field descriptors, the union halo, composition and setup.
|
||||
!
|
||||
! All the boilerplate (identical for every nested operator) is hidden behind a
|
||||
! single type, psb_c_nest_matrix, with the usual PSBLAS init/ins/asb pattern:
|
||||
!
|
||||
! type(psb_c_nest_matrix) :: nested_matrix
|
||||
! call nested_matrix%init(ctxt, [n1, n2], info) ! 2 fields of global size n1, n2
|
||||
! call nested_matrix%ins(1,1, n, rows, cols, vals, info) ! values of block (1,1) = A
|
||||
! call nested_matrix%ins(1,2, n, rows, cols, vals, info) ! values of block (1,2) = B^T
|
||||
! call nested_matrix%ins(2,1, n, rows, cols, vals, info) ! values of block (2,1) = B
|
||||
! ... ! (absent blocks = not inserted)
|
||||
! call nested_matrix%asb(info) ! assemble: builds a_glob, desc_glob
|
||||
!
|
||||
! ! from here on nested_matrix%a_glob and nested_matrix%desc_glob are an
|
||||
! ! ordinary distributed matrix/descriptor:
|
||||
! call psb_geall(x, nested_matrix%desc_glob, info)
|
||||
! call psb_krylov('CG', nested_matrix%a_glob, prec, b, x, eps, nested_matrix%desc_glob, info, ...)
|
||||
!
|
||||
! Indices: in ins(block_row, block_col, ...) the rows live in the index space of
|
||||
! field block_row, the columns in the index space of field block_col (GLOBAL
|
||||
! field indices, 1..field_size). Each process inserts only the rows it owns
|
||||
! (PSBLAS convention). Off-diagonal blocks may be rectangular.
|
||||
!
|
||||
! NOTE: after asb the object holds consistent internal pointers (a_glob%a points
|
||||
! to block_storage / grid_desc): do not copy/move the object after assembly.
|
||||
!
|
||||
module psb_c_nest_builder_mod
|
||||
use psb_const_mod
|
||||
use psb_error_mod, only : psb_errpush
|
||||
use psb_penv_mod, only : psb_ctxt_type, psb_info
|
||||
use psb_desc_mod, only : psb_desc_type
|
||||
use psb_c_mat_mod, only : psb_cspmat_type
|
||||
use psb_c_base_mat_mod, only : psb_c_base_sparse_mat
|
||||
use psb_cd_tools_mod, only : psb_cdall, psb_cdins, psb_cdasb
|
||||
use psb_desc_nest_mod, only : psb_desc_nest_type
|
||||
use psb_c_nest_mat_mod, only : psb_c_nest_sparse_mat
|
||||
use psb_c_nest_base_mat_mod, only : psb_c_nest_base_mat, psb_c_nest_base_setup
|
||||
use psb_cd_nest_tools_mod, only : psb_cd_nest_compose
|
||||
use psb_c_nest_tools_mod, only : psb_c_nest_rect_block
|
||||
implicit none
|
||||
|
||||
! growing triplet buffer for a single block
|
||||
type :: psb_c_nest_block_buffer
|
||||
integer(psb_ipk_) :: n_entries = 0
|
||||
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_spk_), allocatable :: entry_vals(:)
|
||||
end type psb_c_nest_block_buffer
|
||||
|
||||
type :: psb_c_nest_matrix
|
||||
type(psb_ctxt_type) :: context
|
||||
integer(psb_ipk_) :: n_fields = 0
|
||||
logical :: assembled = .false.
|
||||
! construction state
|
||||
type(psb_desc_type), allocatable :: field_desc(:) ! one descriptor per field
|
||||
type(psb_c_nest_block_buffer), allocatable :: block_buffer(:,:) ! triplets per block (i,j)
|
||||
! products (owned; the pointers in a_glob%a point in here)
|
||||
type(psb_c_nest_sparse_mat) :: block_storage
|
||||
type(psb_desc_nest_type) :: grid_desc
|
||||
type(psb_cspmat_type) :: a_glob ! the matrix to hand to Krylov
|
||||
type(psb_desc_type) :: desc_glob ! the global descriptor
|
||||
contains
|
||||
procedure, pass(op) :: init => psb_c_nest_op_init
|
||||
procedure, pass(op) :: ins => psb_c_nest_op_ins
|
||||
procedure, pass(op) :: asb => psb_c_nest_op_asb
|
||||
procedure, pass(op) :: free => psb_c_nest_op_free
|
||||
! user-friendly queries on the field row distribution (no descriptor
|
||||
! jargon needed: these replace field_desc(i)%get_local_rows() / %l2g(...))
|
||||
procedure, pass(op) :: get_owned_rows => psb_c_nest_op_get_owned_rows
|
||||
procedure, pass(op) :: get_owned_row_count => psb_c_nest_op_get_owned_row_count
|
||||
end type psb_c_nest_matrix
|
||||
|
||||
private
|
||||
public :: psb_c_nest_matrix
|
||||
|
||||
contains
|
||||
|
||||
! init: create one descriptor per field (block distribution from the global sizes)
|
||||
subroutine psb_c_nest_op_init(op, context, field_sizes, info)
|
||||
class(psb_c_nest_matrix), intent(inout) :: op
|
||||
type(psb_ctxt_type), intent(in) :: context
|
||||
integer(psb_lpk_), intent(in) :: field_sizes(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: my_rank, num_procs, n_fields, i_field, field_local_rows
|
||||
integer(psb_lpk_) :: field_global_size
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_c_nest_op_init'
|
||||
|
||||
call psb_info(context, my_rank, num_procs)
|
||||
n_fields = size(field_sizes)
|
||||
op%context = context
|
||||
op%n_fields = n_fields
|
||||
op%assembled = .false.
|
||||
|
||||
allocate(op%field_desc(n_fields), op%block_buffer(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
|
||||
do i_field = 1, n_fields
|
||||
field_global_size = field_sizes(i_field)
|
||||
! block distribution: field_global_size rows over num_procs processes (total size invariant)
|
||||
field_local_rows = int(field_global_size / int(num_procs, psb_lpk_), psb_ipk_)
|
||||
if (int(my_rank, psb_lpk_) < mod(field_global_size, int(num_procs, psb_lpk_))) &
|
||||
& field_local_rows = field_local_rows + 1
|
||||
call psb_cdall(context, op%field_desc(i_field), info, nl=field_local_rows)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdall'); return
|
||||
end if
|
||||
end do
|
||||
end subroutine psb_c_nest_op_init
|
||||
|
||||
! ins: accumulate the triplets into block (block_row,block_col) and register the
|
||||
! columns (field block_col index space) into that descriptor's union halo
|
||||
subroutine psb_c_nest_op_ins(op, block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info)
|
||||
class(psb_c_nest_matrix), intent(inout) :: op
|
||||
integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_spk_), intent(in) :: entry_vals(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_c_nest_op_ins'
|
||||
|
||||
if (op%assembled) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='operator already assembled'); return
|
||||
end if
|
||||
if (block_row < 1 .or. block_row > op%n_fields .or. &
|
||||
& block_col < 1 .or. block_col > op%n_fields) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='block index out of range'); return
|
||||
end if
|
||||
if (n_entries <= 0) return
|
||||
|
||||
call block_buffer_append(op%block_buffer(block_row,block_col), n_entries, &
|
||||
& entry_rows, entry_cols, entry_vals, info)
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
|
||||
! the columns of block (block_row,block_col) live in field block_col ->
|
||||
! register their indices into that descriptor's union halo
|
||||
! (this also applies when block_col == block_row)
|
||||
call psb_cdins(n_entries, entry_cols(1:n_entries), op%field_desc(block_col), info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins'); return
|
||||
end if
|
||||
end subroutine psb_c_nest_op_ins
|
||||
|
||||
! asb: assemble the descriptors, build the blocks, compose the global
|
||||
! descriptor, set up the operator and wrap it into a_glob.
|
||||
! The optional type ('CSR'/'CSC'/'COO', default 'CSR') or mold (any
|
||||
! class extending psb_c_base_sparse_mat, e.g. the psb_ext ELL/HLL or
|
||||
! the psb_cuda device formats) selects the storage format of the blocks.
|
||||
subroutine psb_c_nest_op_asb(op, info, type, mold)
|
||||
class(psb_c_nest_matrix), intent(inout), target :: op
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: mold
|
||||
|
||||
type(psb_c_nest_base_mat) :: nest_operator
|
||||
integer(psb_ipk_) :: n_fields, i_field, j_field
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_c_nest_op_asb'
|
||||
n_fields = op%n_fields
|
||||
|
||||
! 1) assemble the per-field descriptors (with the union halo accumulated in ins)
|
||||
do i_field = 1, n_fields
|
||||
call psb_cdasb(op%field_desc(i_field), info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb'); return
|
||||
end if
|
||||
end do
|
||||
|
||||
! 2) build the local blocks (generally rectangular) from the triplets
|
||||
op%block_storage%nrblocks = n_fields
|
||||
op%block_storage%ncblocks = n_fields
|
||||
allocate(op%block_storage%mats(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
if (op%block_buffer(i_field,j_field)%n_entries > 0) then
|
||||
call psb_c_nest_rect_block(op%block_storage%mats(i_field,j_field), &
|
||||
& op%block_buffer(i_field,j_field)%n_entries, &
|
||||
& op%block_buffer(i_field,j_field)%entry_rows, &
|
||||
& op%block_buffer(i_field,j_field)%entry_cols, &
|
||||
& op%block_buffer(i_field,j_field)%entry_vals, &
|
||||
& op%field_desc(i_field), op%field_desc(j_field), info, &
|
||||
& type=type, mold=mold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='rect_block'); return
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
! 3) descriptor grid: descs(i,j) = descriptor of field j
|
||||
op%grid_desc%nrblocks = n_fields
|
||||
op%grid_desc%ncblocks = n_fields
|
||||
allocate(op%grid_desc%descs(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
call op%field_desc(j_field)%clone(op%grid_desc%descs(i_field,j_field), info)
|
||||
end do
|
||||
end do
|
||||
|
||||
! 4) composed global descriptor + operator setup
|
||||
call psb_cd_nest_compose(op%grid_desc, op%desc_glob, info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='cd_nest_compose'); return
|
||||
end if
|
||||
call psb_c_nest_base_setup(nest_operator, op%block_storage, op%grid_desc, op%desc_glob, info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='nest_base_setup'); return
|
||||
end if
|
||||
|
||||
! 5) wrap into the standard matrix object (the pointers keep pointing at op%*)
|
||||
allocate(op%a_glob%a, source=nest_operator, stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
call op%a_glob%set_nrows(op%desc_glob%get_local_rows())
|
||||
call op%a_glob%set_ncols(op%desc_glob%get_local_cols())
|
||||
call op%a_glob%set_asb()
|
||||
|
||||
! 6) the triplet buffers are no longer needed
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
call block_buffer_free(op%block_buffer(i_field,j_field))
|
||||
end do
|
||||
end do
|
||||
op%assembled = .true.
|
||||
end subroutine psb_c_nest_op_asb
|
||||
|
||||
! free: release everything
|
||||
subroutine psb_c_nest_op_free(op, info)
|
||||
class(psb_c_nest_matrix), intent(inout) :: op
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i_field, j_field, local_info
|
||||
|
||||
info = psb_success_
|
||||
if (allocated(op%block_buffer)) then
|
||||
do j_field = 1, size(op%block_buffer,2)
|
||||
do i_field = 1, size(op%block_buffer,1)
|
||||
call block_buffer_free(op%block_buffer(i_field,j_field))
|
||||
end do
|
||||
end do
|
||||
deallocate(op%block_buffer, stat=local_info)
|
||||
end if
|
||||
if (op%assembled) then
|
||||
call op%a_glob%free()
|
||||
call op%desc_glob%free(local_info)
|
||||
call op%grid_desc%free(local_info)
|
||||
end if
|
||||
if (allocated(op%field_desc)) then
|
||||
do i_field = 1, size(op%field_desc)
|
||||
call op%field_desc(i_field)%free(local_info)
|
||||
end do
|
||||
deallocate(op%field_desc, stat=local_info)
|
||||
end if
|
||||
op%n_fields = 0
|
||||
op%assembled = .false.
|
||||
end subroutine psb_c_nest_op_free
|
||||
|
||||
! get_owned_rows: GLOBAL indices (in the field index space, 1..field size)
|
||||
! of the rows of field i_field owned by this process. This is the list of
|
||||
! rows the process is expected to insert through ins:
|
||||
!
|
||||
! my_rows = nested_matrix%get_owned_rows(1)
|
||||
! do k = 1, size(my_rows)
|
||||
! global_row = my_rows(k)
|
||||
! ...
|
||||
!
|
||||
! An empty array is returned for an out-of-range field index.
|
||||
function psb_c_nest_op_get_owned_rows(op, i_field) result(owned_global_rows)
|
||||
class(psb_c_nest_matrix), intent(in) :: op
|
||||
integer(psb_ipk_), intent(in) :: i_field
|
||||
integer(psb_lpk_), allocatable :: owned_global_rows(:)
|
||||
|
||||
if ((i_field < 1) .or. (i_field > op%n_fields) .or. &
|
||||
& (.not. allocated(op%field_desc))) then
|
||||
allocate(owned_global_rows(0))
|
||||
return
|
||||
end if
|
||||
owned_global_rows = op%field_desc(i_field)%get_global_indices(owned=.true.)
|
||||
end function psb_c_nest_op_get_owned_rows
|
||||
|
||||
! get_owned_row_count: how many rows of field i_field this process owns
|
||||
function psb_c_nest_op_get_owned_row_count(op, i_field) result(owned_row_count)
|
||||
class(psb_c_nest_matrix), intent(in) :: op
|
||||
integer(psb_ipk_), intent(in) :: i_field
|
||||
integer(psb_ipk_) :: owned_row_count
|
||||
|
||||
owned_row_count = 0
|
||||
if ((i_field < 1) .or. (i_field > op%n_fields) .or. &
|
||||
& (.not. allocated(op%field_desc))) return
|
||||
owned_row_count = op%field_desc(i_field)%get_local_rows()
|
||||
end function psb_c_nest_op_get_owned_row_count
|
||||
|
||||
!-----------------------------------------------------------------
|
||||
! private helpers: growing triplet buffer
|
||||
!-----------------------------------------------------------------
|
||||
subroutine block_buffer_append(buffer, n_entries, entry_rows, entry_cols, entry_vals, info)
|
||||
type(psb_c_nest_block_buffer), intent(inout) :: buffer
|
||||
integer(psb_ipk_), intent(in) :: n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_spk_), intent(in) :: entry_vals(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: required_size
|
||||
|
||||
info = psb_success_
|
||||
required_size = buffer%n_entries + n_entries
|
||||
call ensure_capacity_lpk(buffer%entry_rows, required_size, info); if (info /= 0) return
|
||||
call ensure_capacity_lpk(buffer%entry_cols, required_size, info); if (info /= 0) return
|
||||
call ensure_capacity_val(buffer%entry_vals, required_size, info); if (info /= 0) return
|
||||
buffer%entry_rows(buffer%n_entries+1:required_size) = entry_rows(1:n_entries)
|
||||
buffer%entry_cols(buffer%n_entries+1:required_size) = entry_cols(1:n_entries)
|
||||
buffer%entry_vals(buffer%n_entries+1:required_size) = entry_vals(1:n_entries)
|
||||
buffer%n_entries = required_size
|
||||
end subroutine block_buffer_append
|
||||
|
||||
subroutine ensure_capacity_lpk(array, required_size, info)
|
||||
integer(psb_lpk_), allocatable, intent(inout) :: array(:)
|
||||
integer(psb_ipk_), intent(in) :: required_size
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_lpk_), allocatable :: grown(:)
|
||||
integer(psb_ipk_) :: capacity
|
||||
|
||||
info = 0
|
||||
if (.not. allocated(array)) then
|
||||
allocate(array(max(required_size,16)), stat=info); return
|
||||
end if
|
||||
capacity = size(array)
|
||||
if (required_size <= capacity) return
|
||||
allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return
|
||||
grown(1:capacity) = array(1:capacity)
|
||||
call move_alloc(grown, array)
|
||||
end subroutine ensure_capacity_lpk
|
||||
|
||||
subroutine ensure_capacity_val(array, required_size, info)
|
||||
complex(psb_spk_), allocatable, intent(inout) :: array(:)
|
||||
integer(psb_ipk_), intent(in) :: required_size
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), allocatable :: grown(:)
|
||||
integer(psb_ipk_) :: capacity
|
||||
|
||||
info = 0
|
||||
if (.not. allocated(array)) then
|
||||
allocate(array(max(required_size,16)), stat=info); return
|
||||
end if
|
||||
capacity = size(array)
|
||||
if (required_size <= capacity) return
|
||||
allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return
|
||||
grown(1:capacity) = array(1:capacity)
|
||||
call move_alloc(grown, array)
|
||||
end subroutine ensure_capacity_val
|
||||
|
||||
subroutine block_buffer_free(buffer)
|
||||
type(psb_c_nest_block_buffer), intent(inout) :: buffer
|
||||
if (allocated(buffer%entry_rows)) deallocate(buffer%entry_rows)
|
||||
if (allocated(buffer%entry_cols)) deallocate(buffer%entry_cols)
|
||||
if (allocated(buffer%entry_vals)) deallocate(buffer%entry_vals)
|
||||
buffer%n_entries = 0
|
||||
end subroutine block_buffer_free
|
||||
|
||||
end module psb_c_nest_builder_mod
|
||||
@ -0,0 +1,364 @@
|
||||
!
|
||||
! 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_c_nest_tools_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Nested-specific assembly wrappers for PSBLAS3 — double precision matrix and vector routines
|
||||
!
|
||||
|
||||
module psb_c_nest_tools_mod
|
||||
use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_spk_, psb_success_, psb_err_alloc_dealloc_, &
|
||||
psb_err_invalid_input_, psb_err_from_subroutine_, &
|
||||
psb_dupl_add_, psb_dupl_ovwrt_, psb_dupl_err_, psb_ctxt_type
|
||||
use psb_error_mod, only : psb_errpush
|
||||
use psb_c_tools_mod, only : psb_spall, psb_spins, psb_spasb, psb_spfree, psb_sprn, &
|
||||
psb_geall, psb_geins, psb_geasb, psb_gefree
|
||||
use psb_desc_nest_mod, only : psb_desc_nest_type
|
||||
use psb_c_nest_mat_mod, only : psb_c_nest_sparse_mat
|
||||
use psb_c_mat_mod, only : psb_cspmat_type
|
||||
use psb_c_base_mat_mod, only : psb_c_coo_sparse_mat, psb_c_base_sparse_mat
|
||||
use psb_desc_mod, only : psb_desc_type
|
||||
implicit none
|
||||
|
||||
private
|
||||
|
||||
public :: psb_spall_nest, psb_spins_nest, psb_spasb_nest, psb_spfree_nest, psb_sprn_nest, &
|
||||
psb_c_nest_rect_block
|
||||
|
||||
contains
|
||||
|
||||
! Allocates all (nrblocks x ncblocks) sparse matrix blocks
|
||||
! and marks all as present. psb_spins_nest lazy-allocates individual
|
||||
! blocks on first insertion; call psb_spall_nest instead when the
|
||||
! full block structure is known up front.
|
||||
|
||||
subroutine psb_spall_nest(a_nest, desc_nest, info, nnz)
|
||||
type(psb_c_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: nnz
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spall_nest'
|
||||
|
||||
a_nest%nrblocks = desc_nest%nrblocks
|
||||
a_nest%ncblocks = desc_nest%ncblocks
|
||||
|
||||
if (.not. allocated(a_nest%mats)) then
|
||||
allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
local_info = psb_success_
|
||||
if (present(nnz)) then
|
||||
call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, nnz=nnz)
|
||||
else
|
||||
call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall')
|
||||
return
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_spall_nest
|
||||
|
||||
|
||||
! Inserts nz entries into block (blk_i, blk_j) of the nested matrix.
|
||||
! The block is lazy-allocated on first insertion if psb_spall_nest
|
||||
! was not called first.
|
||||
|
||||
subroutine psb_spins_nest(block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, a_nest, desc_nest, info)
|
||||
integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_spk_), intent(in) :: entry_vals(:)
|
||||
type(psb_c_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: nnz_estimate
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spins_nest'
|
||||
|
||||
if (n_entries == 0) return
|
||||
|
||||
if (block_row < 1 .or. block_row > a_nest%nrblocks .or. &
|
||||
block_col < 1 .or. block_col > a_nest%ncblocks) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='invalid block indices')
|
||||
return
|
||||
end if
|
||||
|
||||
if (.not. allocated(a_nest%mats)) then
|
||||
allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not. allocated(a_nest%mats(block_row, block_col)%a)) then
|
||||
! Estimate nnz: use n_entries + 50% buffer for future insertions
|
||||
nnz_estimate = max(n_entries, 10) + n_entries / 2
|
||||
call psb_spall(a_nest%mats(block_row, block_col), &
|
||||
desc_nest%descs(block_row, block_col), info, nnz=nnz_estimate)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall')
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_spins(n_entries, entry_rows, entry_cols, entry_vals, a_nest%mats(block_row, block_col), &
|
||||
desc_nest%descs(block_row, block_col), info)
|
||||
if (info /= psb_success_) &
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spins')
|
||||
|
||||
end subroutine psb_spins_nest
|
||||
|
||||
! Calls psb_spasb on all present block matrices.
|
||||
! Must be called after psb_cdasb_nest.
|
||||
|
||||
subroutine psb_spasb_nest(a_nest, desc_nest, info, dupl)
|
||||
type(psb_c_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: dupl
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, dupl_mode, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spasb_nest'
|
||||
dupl_mode = psb_dupl_add_
|
||||
if (present(dupl)) dupl_mode = dupl
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
if (dupl_mode == psb_dupl_add_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_add_)
|
||||
else if (dupl_mode == psb_dupl_ovwrt_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_ovwrt_)
|
||||
else if (dupl_mode == psb_dupl_err_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_err_)
|
||||
else
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spasb')
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_spasb_nest
|
||||
|
||||
! Calls psb_spfree on every present block, then deallocates the
|
||||
! mats array and resets nrblocks/ncblocks to 0.
|
||||
|
||||
subroutine psb_spfree_nest(a_nest, desc_nest, info)
|
||||
type(psb_c_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spfree_nest'
|
||||
|
||||
if (allocated(a_nest%mats)) then
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
call psb_spfree(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
if (local_info /= psb_success_ .and. info == psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spfree')
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
deallocate(a_nest%mats, stat=local_info)
|
||||
if (local_info /= 0 .and. info == psb_success_) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
end if
|
||||
end if
|
||||
|
||||
a_nest%nrblocks = 0
|
||||
a_nest%ncblocks = 0
|
||||
|
||||
end subroutine psb_spfree_nest
|
||||
|
||||
! Calls psb_sprn on every present block matrix, resetting it to
|
||||
! the build state while preserving the sparsity pattern.
|
||||
|
||||
subroutine psb_sprn_nest(a_nest, desc_nest, info, clear)
|
||||
type(psb_c_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: clear
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_sprn_nest'
|
||||
|
||||
if (.not. allocated(a_nest%mats)) return
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
if (present(clear)) then
|
||||
call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, clear=clear)
|
||||
else
|
||||
call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_ .and. info == psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_sprn')
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_sprn_nest
|
||||
|
||||
|
||||
|
||||
! psb_c_nest_rect_block
|
||||
!
|
||||
! Build a local GENERAL (possibly rectangular) block A(i,j) of a nested
|
||||
! operator, with rows in field i and columns in field j (field i /= field j,
|
||||
! |field i| /= |field j| allowed). Rows are localized against the field-i
|
||||
! (row) descriptor, columns against the field-j (column) descriptor — which
|
||||
! must already carry the union halo of column j (cdall + cdins(all column-j
|
||||
! blocks' columns) + cdasb). The result is a CSR block of shape
|
||||
! (field-i owned rows) x (field-j local cols incl. halo)
|
||||
! consumable directly by the nested csmv (psb_c_nest_base_mat).
|
||||
!
|
||||
! A single-descriptor psb_spall/psb_spasb cannot express row-field /= col-field
|
||||
! (it would force rows and columns into the same index space), hence the
|
||||
! explicit COO build with separate row/column localization.
|
||||
!
|
||||
! Arguments (this process's local contribution):
|
||||
! blk (out) the assembled block (CSR)
|
||||
! nz number of local entries
|
||||
! ia_glob(:) GLOBAL field-i row indices (owned by this process)
|
||||
! ja_glob(:) GLOBAL field-j column indices
|
||||
! val(:) values
|
||||
! desc_row field-i descriptor (rows)
|
||||
! desc_col field-j descriptor (columns, with union halo)
|
||||
!
|
||||
subroutine psb_c_nest_rect_block(blk, nz, ia_glob, ja_glob, val, desc_row, desc_col, info, type, mold)
|
||||
type(psb_cspmat_type), intent(out) :: blk
|
||||
integer(psb_ipk_), intent(in) :: nz
|
||||
integer(psb_lpk_), intent(in) :: ia_glob(:), ja_glob(:)
|
||||
complex(psb_spk_), intent(in) :: val(:)
|
||||
type(psb_desc_type), intent(in) :: desc_row, desc_col
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type ! base storage format (default 'CSR')
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: mold ! any format, e.g. psb_ext ELL/HLL
|
||||
|
||||
type(psb_c_coo_sparse_mat) :: coo_block
|
||||
integer(psb_ipk_) :: k_entry, n_loc_rows, n_loc_cols, loc_row, loc_col
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_c_nest_rect_block'
|
||||
|
||||
n_loc_rows = desc_row%get_local_rows() ! owned rows of field i
|
||||
n_loc_cols = desc_col%get_local_cols() ! field-j local cols (owned + halo)
|
||||
|
||||
call coo_block%allocate(n_loc_rows, n_loc_cols, nz)
|
||||
do k_entry = 1, nz
|
||||
call desc_row%g2l(ia_glob(k_entry), loc_row, info)
|
||||
if (info /= 0 .or. loc_row < 1 .or. loc_row > n_loc_rows) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='row not owned / not localizable')
|
||||
return
|
||||
end if
|
||||
call desc_col%g2l(ja_glob(k_entry), loc_col, info)
|
||||
if (info /= 0 .or. loc_col < 1 .or. loc_col > n_loc_cols) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='column not in field-j descriptor (missing from union halo)')
|
||||
return
|
||||
end if
|
||||
coo_block%ia(k_entry) = loc_row
|
||||
coo_block%ja(k_entry) = loc_col
|
||||
coo_block%val(k_entry) = val(k_entry)
|
||||
end do
|
||||
call coo_block%set_nzeros(nz)
|
||||
call coo_block%set_dupl(psb_dupl_add_)
|
||||
call coo_block%fix(info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix'); return
|
||||
end if
|
||||
call blk%mv_from(coo_block)
|
||||
if (present(mold)) then
|
||||
call blk%cscnv(info, mold=mold)
|
||||
else if (present(type)) then
|
||||
call blk%cscnv(info, type=type)
|
||||
else
|
||||
call blk%cscnv(info, type='CSR')
|
||||
end if
|
||||
if (info /= 0) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='cscnv'); return
|
||||
end if
|
||||
end subroutine psb_c_nest_rect_block
|
||||
|
||||
end module psb_c_nest_tools_mod
|
||||
@ -0,0 +1,414 @@
|
||||
!
|
||||
! 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 prior written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: psb_s_nest_builder_mod.F90
|
||||
!
|
||||
! Module: psb_s_nest_builder_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! User-friendly frontend to build a nested (MATNEST) operator without manually
|
||||
! managing per-field descriptors, the union halo, composition and setup.
|
||||
!
|
||||
! All the boilerplate (identical for every nested operator) is hidden behind a
|
||||
! single type, psb_s_nest_matrix, with the usual PSBLAS init/ins/asb pattern:
|
||||
!
|
||||
! type(psb_s_nest_matrix) :: nested_matrix
|
||||
! call nested_matrix%init(ctxt, [n1, n2], info) ! 2 fields of global size n1, n2
|
||||
! call nested_matrix%ins(1,1, n, rows, cols, vals, info) ! values of block (1,1) = A
|
||||
! call nested_matrix%ins(1,2, n, rows, cols, vals, info) ! values of block (1,2) = B^T
|
||||
! call nested_matrix%ins(2,1, n, rows, cols, vals, info) ! values of block (2,1) = B
|
||||
! ... ! (absent blocks = not inserted)
|
||||
! call nested_matrix%asb(info) ! assemble: builds a_glob, desc_glob
|
||||
!
|
||||
! ! from here on nested_matrix%a_glob and nested_matrix%desc_glob are an
|
||||
! ! ordinary distributed matrix/descriptor:
|
||||
! call psb_geall(x, nested_matrix%desc_glob, info)
|
||||
! call psb_krylov('CG', nested_matrix%a_glob, prec, b, x, eps, nested_matrix%desc_glob, info, ...)
|
||||
!
|
||||
! Indices: in ins(block_row, block_col, ...) the rows live in the index space of
|
||||
! field block_row, the columns in the index space of field block_col (GLOBAL
|
||||
! field indices, 1..field_size). Each process inserts only the rows it owns
|
||||
! (PSBLAS convention). Off-diagonal blocks may be rectangular.
|
||||
!
|
||||
! NOTE: after asb the object holds consistent internal pointers (a_glob%a points
|
||||
! to block_storage / grid_desc): do not copy/move the object after assembly.
|
||||
!
|
||||
module psb_s_nest_builder_mod
|
||||
use psb_const_mod
|
||||
use psb_error_mod, only : psb_errpush
|
||||
use psb_penv_mod, only : psb_ctxt_type, psb_info
|
||||
use psb_desc_mod, only : psb_desc_type
|
||||
use psb_s_mat_mod, only : psb_sspmat_type
|
||||
use psb_s_base_mat_mod, only : psb_s_base_sparse_mat
|
||||
use psb_cd_tools_mod, only : psb_cdall, psb_cdins, psb_cdasb
|
||||
use psb_desc_nest_mod, only : psb_desc_nest_type
|
||||
use psb_s_nest_mat_mod, only : psb_s_nest_sparse_mat
|
||||
use psb_s_nest_base_mat_mod, only : psb_s_nest_base_mat, psb_s_nest_base_setup
|
||||
use psb_cd_nest_tools_mod, only : psb_cd_nest_compose
|
||||
use psb_s_nest_tools_mod, only : psb_s_nest_rect_block
|
||||
implicit none
|
||||
|
||||
! growing triplet buffer for a single block
|
||||
type :: psb_s_nest_block_buffer
|
||||
integer(psb_ipk_) :: n_entries = 0
|
||||
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
|
||||
real(psb_spk_), allocatable :: entry_vals(:)
|
||||
end type psb_s_nest_block_buffer
|
||||
|
||||
type :: psb_s_nest_matrix
|
||||
type(psb_ctxt_type) :: context
|
||||
integer(psb_ipk_) :: n_fields = 0
|
||||
logical :: assembled = .false.
|
||||
! construction state
|
||||
type(psb_desc_type), allocatable :: field_desc(:) ! one descriptor per field
|
||||
type(psb_s_nest_block_buffer), allocatable :: block_buffer(:,:) ! triplets per block (i,j)
|
||||
! products (owned; the pointers in a_glob%a point in here)
|
||||
type(psb_s_nest_sparse_mat) :: block_storage
|
||||
type(psb_desc_nest_type) :: grid_desc
|
||||
type(psb_sspmat_type) :: a_glob ! the matrix to hand to Krylov
|
||||
type(psb_desc_type) :: desc_glob ! the global descriptor
|
||||
contains
|
||||
procedure, pass(op) :: init => psb_s_nest_op_init
|
||||
procedure, pass(op) :: ins => psb_s_nest_op_ins
|
||||
procedure, pass(op) :: asb => psb_s_nest_op_asb
|
||||
procedure, pass(op) :: free => psb_s_nest_op_free
|
||||
! user-friendly queries on the field row distribution (no descriptor
|
||||
! jargon needed: these replace field_desc(i)%get_local_rows() / %l2g(...))
|
||||
procedure, pass(op) :: get_owned_rows => psb_s_nest_op_get_owned_rows
|
||||
procedure, pass(op) :: get_owned_row_count => psb_s_nest_op_get_owned_row_count
|
||||
end type psb_s_nest_matrix
|
||||
|
||||
private
|
||||
public :: psb_s_nest_matrix
|
||||
|
||||
contains
|
||||
|
||||
! init: create one descriptor per field (block distribution from the global sizes)
|
||||
subroutine psb_s_nest_op_init(op, context, field_sizes, info)
|
||||
class(psb_s_nest_matrix), intent(inout) :: op
|
||||
type(psb_ctxt_type), intent(in) :: context
|
||||
integer(psb_lpk_), intent(in) :: field_sizes(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: my_rank, num_procs, n_fields, i_field, field_local_rows
|
||||
integer(psb_lpk_) :: field_global_size
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_s_nest_op_init'
|
||||
|
||||
call psb_info(context, my_rank, num_procs)
|
||||
n_fields = size(field_sizes)
|
||||
op%context = context
|
||||
op%n_fields = n_fields
|
||||
op%assembled = .false.
|
||||
|
||||
allocate(op%field_desc(n_fields), op%block_buffer(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
|
||||
do i_field = 1, n_fields
|
||||
field_global_size = field_sizes(i_field)
|
||||
! block distribution: field_global_size rows over num_procs processes (total size invariant)
|
||||
field_local_rows = int(field_global_size / int(num_procs, psb_lpk_), psb_ipk_)
|
||||
if (int(my_rank, psb_lpk_) < mod(field_global_size, int(num_procs, psb_lpk_))) &
|
||||
& field_local_rows = field_local_rows + 1
|
||||
call psb_cdall(context, op%field_desc(i_field), info, nl=field_local_rows)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdall'); return
|
||||
end if
|
||||
end do
|
||||
end subroutine psb_s_nest_op_init
|
||||
|
||||
! ins: accumulate the triplets into block (block_row,block_col) and register the
|
||||
! columns (field block_col index space) into that descriptor's union halo
|
||||
subroutine psb_s_nest_op_ins(op, block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info)
|
||||
class(psb_s_nest_matrix), intent(inout) :: op
|
||||
integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
real(psb_spk_), intent(in) :: entry_vals(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_s_nest_op_ins'
|
||||
|
||||
if (op%assembled) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='operator already assembled'); return
|
||||
end if
|
||||
if (block_row < 1 .or. block_row > op%n_fields .or. &
|
||||
& block_col < 1 .or. block_col > op%n_fields) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='block index out of range'); return
|
||||
end if
|
||||
if (n_entries <= 0) return
|
||||
|
||||
call block_buffer_append(op%block_buffer(block_row,block_col), n_entries, &
|
||||
& entry_rows, entry_cols, entry_vals, info)
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
|
||||
! the columns of block (block_row,block_col) live in field block_col ->
|
||||
! register their indices into that descriptor's union halo
|
||||
! (this also applies when block_col == block_row)
|
||||
call psb_cdins(n_entries, entry_cols(1:n_entries), op%field_desc(block_col), info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins'); return
|
||||
end if
|
||||
end subroutine psb_s_nest_op_ins
|
||||
|
||||
! asb: assemble the descriptors, build the blocks, compose the global
|
||||
! descriptor, set up the operator and wrap it into a_glob.
|
||||
! The optional type ('CSR'/'CSC'/'COO', default 'CSR') or mold (any
|
||||
! class extending psb_s_base_sparse_mat, e.g. the psb_ext ELL/HLL or
|
||||
! the psb_cuda device formats) selects the storage format of the blocks.
|
||||
subroutine psb_s_nest_op_asb(op, info, type, mold)
|
||||
class(psb_s_nest_matrix), intent(inout), target :: op
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: mold
|
||||
|
||||
type(psb_s_nest_base_mat) :: nest_operator
|
||||
integer(psb_ipk_) :: n_fields, i_field, j_field
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_s_nest_op_asb'
|
||||
n_fields = op%n_fields
|
||||
|
||||
! 1) assemble the per-field descriptors (with the union halo accumulated in ins)
|
||||
do i_field = 1, n_fields
|
||||
call psb_cdasb(op%field_desc(i_field), info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb'); return
|
||||
end if
|
||||
end do
|
||||
|
||||
! 2) build the local blocks (generally rectangular) from the triplets
|
||||
op%block_storage%nrblocks = n_fields
|
||||
op%block_storage%ncblocks = n_fields
|
||||
allocate(op%block_storage%mats(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
if (op%block_buffer(i_field,j_field)%n_entries > 0) then
|
||||
call psb_s_nest_rect_block(op%block_storage%mats(i_field,j_field), &
|
||||
& op%block_buffer(i_field,j_field)%n_entries, &
|
||||
& op%block_buffer(i_field,j_field)%entry_rows, &
|
||||
& op%block_buffer(i_field,j_field)%entry_cols, &
|
||||
& op%block_buffer(i_field,j_field)%entry_vals, &
|
||||
& op%field_desc(i_field), op%field_desc(j_field), info, &
|
||||
& type=type, mold=mold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='rect_block'); return
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
! 3) descriptor grid: descs(i,j) = descriptor of field j
|
||||
op%grid_desc%nrblocks = n_fields
|
||||
op%grid_desc%ncblocks = n_fields
|
||||
allocate(op%grid_desc%descs(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
call op%field_desc(j_field)%clone(op%grid_desc%descs(i_field,j_field), info)
|
||||
end do
|
||||
end do
|
||||
|
||||
! 4) composed global descriptor + operator setup
|
||||
call psb_cd_nest_compose(op%grid_desc, op%desc_glob, info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='cd_nest_compose'); return
|
||||
end if
|
||||
call psb_s_nest_base_setup(nest_operator, op%block_storage, op%grid_desc, op%desc_glob, info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='nest_base_setup'); return
|
||||
end if
|
||||
|
||||
! 5) wrap into the standard matrix object (the pointers keep pointing at op%*)
|
||||
allocate(op%a_glob%a, source=nest_operator, stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
call op%a_glob%set_nrows(op%desc_glob%get_local_rows())
|
||||
call op%a_glob%set_ncols(op%desc_glob%get_local_cols())
|
||||
call op%a_glob%set_asb()
|
||||
|
||||
! 6) the triplet buffers are no longer needed
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
call block_buffer_free(op%block_buffer(i_field,j_field))
|
||||
end do
|
||||
end do
|
||||
op%assembled = .true.
|
||||
end subroutine psb_s_nest_op_asb
|
||||
|
||||
! free: release everything
|
||||
subroutine psb_s_nest_op_free(op, info)
|
||||
class(psb_s_nest_matrix), intent(inout) :: op
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i_field, j_field, local_info
|
||||
|
||||
info = psb_success_
|
||||
if (allocated(op%block_buffer)) then
|
||||
do j_field = 1, size(op%block_buffer,2)
|
||||
do i_field = 1, size(op%block_buffer,1)
|
||||
call block_buffer_free(op%block_buffer(i_field,j_field))
|
||||
end do
|
||||
end do
|
||||
deallocate(op%block_buffer, stat=local_info)
|
||||
end if
|
||||
if (op%assembled) then
|
||||
call op%a_glob%free()
|
||||
call op%desc_glob%free(local_info)
|
||||
call op%grid_desc%free(local_info)
|
||||
end if
|
||||
if (allocated(op%field_desc)) then
|
||||
do i_field = 1, size(op%field_desc)
|
||||
call op%field_desc(i_field)%free(local_info)
|
||||
end do
|
||||
deallocate(op%field_desc, stat=local_info)
|
||||
end if
|
||||
op%n_fields = 0
|
||||
op%assembled = .false.
|
||||
end subroutine psb_s_nest_op_free
|
||||
|
||||
! get_owned_rows: GLOBAL indices (in the field index space, 1..field size)
|
||||
! of the rows of field i_field owned by this process. This is the list of
|
||||
! rows the process is expected to insert through ins:
|
||||
!
|
||||
! my_rows = nested_matrix%get_owned_rows(1)
|
||||
! do k = 1, size(my_rows)
|
||||
! global_row = my_rows(k)
|
||||
! ...
|
||||
!
|
||||
! An empty array is returned for an out-of-range field index.
|
||||
function psb_s_nest_op_get_owned_rows(op, i_field) result(owned_global_rows)
|
||||
class(psb_s_nest_matrix), intent(in) :: op
|
||||
integer(psb_ipk_), intent(in) :: i_field
|
||||
integer(psb_lpk_), allocatable :: owned_global_rows(:)
|
||||
|
||||
if ((i_field < 1) .or. (i_field > op%n_fields) .or. &
|
||||
& (.not. allocated(op%field_desc))) then
|
||||
allocate(owned_global_rows(0))
|
||||
return
|
||||
end if
|
||||
owned_global_rows = op%field_desc(i_field)%get_global_indices(owned=.true.)
|
||||
end function psb_s_nest_op_get_owned_rows
|
||||
|
||||
! get_owned_row_count: how many rows of field i_field this process owns
|
||||
function psb_s_nest_op_get_owned_row_count(op, i_field) result(owned_row_count)
|
||||
class(psb_s_nest_matrix), intent(in) :: op
|
||||
integer(psb_ipk_), intent(in) :: i_field
|
||||
integer(psb_ipk_) :: owned_row_count
|
||||
|
||||
owned_row_count = 0
|
||||
if ((i_field < 1) .or. (i_field > op%n_fields) .or. &
|
||||
& (.not. allocated(op%field_desc))) return
|
||||
owned_row_count = op%field_desc(i_field)%get_local_rows()
|
||||
end function psb_s_nest_op_get_owned_row_count
|
||||
|
||||
!-----------------------------------------------------------------
|
||||
! private helpers: growing triplet buffer
|
||||
!-----------------------------------------------------------------
|
||||
subroutine block_buffer_append(buffer, n_entries, entry_rows, entry_cols, entry_vals, info)
|
||||
type(psb_s_nest_block_buffer), intent(inout) :: buffer
|
||||
integer(psb_ipk_), intent(in) :: n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
real(psb_spk_), intent(in) :: entry_vals(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: required_size
|
||||
|
||||
info = psb_success_
|
||||
required_size = buffer%n_entries + n_entries
|
||||
call ensure_capacity_lpk(buffer%entry_rows, required_size, info); if (info /= 0) return
|
||||
call ensure_capacity_lpk(buffer%entry_cols, required_size, info); if (info /= 0) return
|
||||
call ensure_capacity_val(buffer%entry_vals, required_size, info); if (info /= 0) return
|
||||
buffer%entry_rows(buffer%n_entries+1:required_size) = entry_rows(1:n_entries)
|
||||
buffer%entry_cols(buffer%n_entries+1:required_size) = entry_cols(1:n_entries)
|
||||
buffer%entry_vals(buffer%n_entries+1:required_size) = entry_vals(1:n_entries)
|
||||
buffer%n_entries = required_size
|
||||
end subroutine block_buffer_append
|
||||
|
||||
subroutine ensure_capacity_lpk(array, required_size, info)
|
||||
integer(psb_lpk_), allocatable, intent(inout) :: array(:)
|
||||
integer(psb_ipk_), intent(in) :: required_size
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_lpk_), allocatable :: grown(:)
|
||||
integer(psb_ipk_) :: capacity
|
||||
|
||||
info = 0
|
||||
if (.not. allocated(array)) then
|
||||
allocate(array(max(required_size,16)), stat=info); return
|
||||
end if
|
||||
capacity = size(array)
|
||||
if (required_size <= capacity) return
|
||||
allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return
|
||||
grown(1:capacity) = array(1:capacity)
|
||||
call move_alloc(grown, array)
|
||||
end subroutine ensure_capacity_lpk
|
||||
|
||||
subroutine ensure_capacity_val(array, required_size, info)
|
||||
real(psb_spk_), allocatable, intent(inout) :: array(:)
|
||||
integer(psb_ipk_), intent(in) :: required_size
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), allocatable :: grown(:)
|
||||
integer(psb_ipk_) :: capacity
|
||||
|
||||
info = 0
|
||||
if (.not. allocated(array)) then
|
||||
allocate(array(max(required_size,16)), stat=info); return
|
||||
end if
|
||||
capacity = size(array)
|
||||
if (required_size <= capacity) return
|
||||
allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return
|
||||
grown(1:capacity) = array(1:capacity)
|
||||
call move_alloc(grown, array)
|
||||
end subroutine ensure_capacity_val
|
||||
|
||||
subroutine block_buffer_free(buffer)
|
||||
type(psb_s_nest_block_buffer), intent(inout) :: buffer
|
||||
if (allocated(buffer%entry_rows)) deallocate(buffer%entry_rows)
|
||||
if (allocated(buffer%entry_cols)) deallocate(buffer%entry_cols)
|
||||
if (allocated(buffer%entry_vals)) deallocate(buffer%entry_vals)
|
||||
buffer%n_entries = 0
|
||||
end subroutine block_buffer_free
|
||||
|
||||
end module psb_s_nest_builder_mod
|
||||
@ -0,0 +1,364 @@
|
||||
!
|
||||
! 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_s_nest_tools_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Nested-specific assembly wrappers for PSBLAS3 — double precision matrix and vector routines
|
||||
!
|
||||
|
||||
module psb_s_nest_tools_mod
|
||||
use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_spk_, psb_success_, psb_err_alloc_dealloc_, &
|
||||
psb_err_invalid_input_, psb_err_from_subroutine_, &
|
||||
psb_dupl_add_, psb_dupl_ovwrt_, psb_dupl_err_, psb_ctxt_type
|
||||
use psb_error_mod, only : psb_errpush
|
||||
use psb_s_tools_mod, only : psb_spall, psb_spins, psb_spasb, psb_spfree, psb_sprn, &
|
||||
psb_geall, psb_geins, psb_geasb, psb_gefree
|
||||
use psb_desc_nest_mod, only : psb_desc_nest_type
|
||||
use psb_s_nest_mat_mod, only : psb_s_nest_sparse_mat
|
||||
use psb_s_mat_mod, only : psb_sspmat_type
|
||||
use psb_s_base_mat_mod, only : psb_s_coo_sparse_mat, psb_s_base_sparse_mat
|
||||
use psb_desc_mod, only : psb_desc_type
|
||||
implicit none
|
||||
|
||||
private
|
||||
|
||||
public :: psb_spall_nest, psb_spins_nest, psb_spasb_nest, psb_spfree_nest, psb_sprn_nest, &
|
||||
psb_s_nest_rect_block
|
||||
|
||||
contains
|
||||
|
||||
! Allocates all (nrblocks x ncblocks) sparse matrix blocks
|
||||
! and marks all as present. psb_spins_nest lazy-allocates individual
|
||||
! blocks on first insertion; call psb_spall_nest instead when the
|
||||
! full block structure is known up front.
|
||||
|
||||
subroutine psb_spall_nest(a_nest, desc_nest, info, nnz)
|
||||
type(psb_s_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: nnz
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spall_nest'
|
||||
|
||||
a_nest%nrblocks = desc_nest%nrblocks
|
||||
a_nest%ncblocks = desc_nest%ncblocks
|
||||
|
||||
if (.not. allocated(a_nest%mats)) then
|
||||
allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
local_info = psb_success_
|
||||
if (present(nnz)) then
|
||||
call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, nnz=nnz)
|
||||
else
|
||||
call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall')
|
||||
return
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_spall_nest
|
||||
|
||||
|
||||
! Inserts nz entries into block (blk_i, blk_j) of the nested matrix.
|
||||
! The block is lazy-allocated on first insertion if psb_spall_nest
|
||||
! was not called first.
|
||||
|
||||
subroutine psb_spins_nest(block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, a_nest, desc_nest, info)
|
||||
integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
real(psb_spk_), intent(in) :: entry_vals(:)
|
||||
type(psb_s_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: nnz_estimate
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spins_nest'
|
||||
|
||||
if (n_entries == 0) return
|
||||
|
||||
if (block_row < 1 .or. block_row > a_nest%nrblocks .or. &
|
||||
block_col < 1 .or. block_col > a_nest%ncblocks) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='invalid block indices')
|
||||
return
|
||||
end if
|
||||
|
||||
if (.not. allocated(a_nest%mats)) then
|
||||
allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not. allocated(a_nest%mats(block_row, block_col)%a)) then
|
||||
! Estimate nnz: use n_entries + 50% buffer for future insertions
|
||||
nnz_estimate = max(n_entries, 10) + n_entries / 2
|
||||
call psb_spall(a_nest%mats(block_row, block_col), &
|
||||
desc_nest%descs(block_row, block_col), info, nnz=nnz_estimate)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall')
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_spins(n_entries, entry_rows, entry_cols, entry_vals, a_nest%mats(block_row, block_col), &
|
||||
desc_nest%descs(block_row, block_col), info)
|
||||
if (info /= psb_success_) &
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spins')
|
||||
|
||||
end subroutine psb_spins_nest
|
||||
|
||||
! Calls psb_spasb on all present block matrices.
|
||||
! Must be called after psb_cdasb_nest.
|
||||
|
||||
subroutine psb_spasb_nest(a_nest, desc_nest, info, dupl)
|
||||
type(psb_s_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: dupl
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, dupl_mode, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spasb_nest'
|
||||
dupl_mode = psb_dupl_add_
|
||||
if (present(dupl)) dupl_mode = dupl
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
if (dupl_mode == psb_dupl_add_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_add_)
|
||||
else if (dupl_mode == psb_dupl_ovwrt_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_ovwrt_)
|
||||
else if (dupl_mode == psb_dupl_err_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_err_)
|
||||
else
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spasb')
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_spasb_nest
|
||||
|
||||
! Calls psb_spfree on every present block, then deallocates the
|
||||
! mats array and resets nrblocks/ncblocks to 0.
|
||||
|
||||
subroutine psb_spfree_nest(a_nest, desc_nest, info)
|
||||
type(psb_s_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spfree_nest'
|
||||
|
||||
if (allocated(a_nest%mats)) then
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
call psb_spfree(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
if (local_info /= psb_success_ .and. info == psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spfree')
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
deallocate(a_nest%mats, stat=local_info)
|
||||
if (local_info /= 0 .and. info == psb_success_) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
end if
|
||||
end if
|
||||
|
||||
a_nest%nrblocks = 0
|
||||
a_nest%ncblocks = 0
|
||||
|
||||
end subroutine psb_spfree_nest
|
||||
|
||||
! Calls psb_sprn on every present block matrix, resetting it to
|
||||
! the build state while preserving the sparsity pattern.
|
||||
|
||||
subroutine psb_sprn_nest(a_nest, desc_nest, info, clear)
|
||||
type(psb_s_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: clear
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_sprn_nest'
|
||||
|
||||
if (.not. allocated(a_nest%mats)) return
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
if (present(clear)) then
|
||||
call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, clear=clear)
|
||||
else
|
||||
call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_ .and. info == psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_sprn')
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_sprn_nest
|
||||
|
||||
|
||||
|
||||
! psb_s_nest_rect_block
|
||||
!
|
||||
! Build a local GENERAL (possibly rectangular) block A(i,j) of a nested
|
||||
! operator, with rows in field i and columns in field j (field i /= field j,
|
||||
! |field i| /= |field j| allowed). Rows are localized against the field-i
|
||||
! (row) descriptor, columns against the field-j (column) descriptor — which
|
||||
! must already carry the union halo of column j (cdall + cdins(all column-j
|
||||
! blocks' columns) + cdasb). The result is a CSR block of shape
|
||||
! (field-i owned rows) x (field-j local cols incl. halo)
|
||||
! consumable directly by the nested csmv (psb_s_nest_base_mat).
|
||||
!
|
||||
! A single-descriptor psb_spall/psb_spasb cannot express row-field /= col-field
|
||||
! (it would force rows and columns into the same index space), hence the
|
||||
! explicit COO build with separate row/column localization.
|
||||
!
|
||||
! Arguments (this process's local contribution):
|
||||
! blk (out) the assembled block (CSR)
|
||||
! nz number of local entries
|
||||
! ia_glob(:) GLOBAL field-i row indices (owned by this process)
|
||||
! ja_glob(:) GLOBAL field-j column indices
|
||||
! val(:) values
|
||||
! desc_row field-i descriptor (rows)
|
||||
! desc_col field-j descriptor (columns, with union halo)
|
||||
!
|
||||
subroutine psb_s_nest_rect_block(blk, nz, ia_glob, ja_glob, val, desc_row, desc_col, info, type, mold)
|
||||
type(psb_sspmat_type), intent(out) :: blk
|
||||
integer(psb_ipk_), intent(in) :: nz
|
||||
integer(psb_lpk_), intent(in) :: ia_glob(:), ja_glob(:)
|
||||
real(psb_spk_), intent(in) :: val(:)
|
||||
type(psb_desc_type), intent(in) :: desc_row, desc_col
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type ! base storage format (default 'CSR')
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: mold ! any format, e.g. psb_ext ELL/HLL
|
||||
|
||||
type(psb_s_coo_sparse_mat) :: coo_block
|
||||
integer(psb_ipk_) :: k_entry, n_loc_rows, n_loc_cols, loc_row, loc_col
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_s_nest_rect_block'
|
||||
|
||||
n_loc_rows = desc_row%get_local_rows() ! owned rows of field i
|
||||
n_loc_cols = desc_col%get_local_cols() ! field-j local cols (owned + halo)
|
||||
|
||||
call coo_block%allocate(n_loc_rows, n_loc_cols, nz)
|
||||
do k_entry = 1, nz
|
||||
call desc_row%g2l(ia_glob(k_entry), loc_row, info)
|
||||
if (info /= 0 .or. loc_row < 1 .or. loc_row > n_loc_rows) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='row not owned / not localizable')
|
||||
return
|
||||
end if
|
||||
call desc_col%g2l(ja_glob(k_entry), loc_col, info)
|
||||
if (info /= 0 .or. loc_col < 1 .or. loc_col > n_loc_cols) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='column not in field-j descriptor (missing from union halo)')
|
||||
return
|
||||
end if
|
||||
coo_block%ia(k_entry) = loc_row
|
||||
coo_block%ja(k_entry) = loc_col
|
||||
coo_block%val(k_entry) = val(k_entry)
|
||||
end do
|
||||
call coo_block%set_nzeros(nz)
|
||||
call coo_block%set_dupl(psb_dupl_add_)
|
||||
call coo_block%fix(info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix'); return
|
||||
end if
|
||||
call blk%mv_from(coo_block)
|
||||
if (present(mold)) then
|
||||
call blk%cscnv(info, mold=mold)
|
||||
else if (present(type)) then
|
||||
call blk%cscnv(info, type=type)
|
||||
else
|
||||
call blk%cscnv(info, type='CSR')
|
||||
end if
|
||||
if (info /= 0) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='cscnv'); return
|
||||
end if
|
||||
end subroutine psb_s_nest_rect_block
|
||||
|
||||
end module psb_s_nest_tools_mod
|
||||
@ -0,0 +1,414 @@
|
||||
!
|
||||
! 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 prior written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: psb_z_nest_builder_mod.F90
|
||||
!
|
||||
! Module: psb_z_nest_builder_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! User-friendly frontend to build a nested (MATNEST) operator without manually
|
||||
! managing per-field descriptors, the union halo, composition and setup.
|
||||
!
|
||||
! All the boilerplate (identical for every nested operator) is hidden behind a
|
||||
! single type, psb_z_nest_matrix, with the usual PSBLAS init/ins/asb pattern:
|
||||
!
|
||||
! type(psb_z_nest_matrix) :: nested_matrix
|
||||
! call nested_matrix%init(ctxt, [n1, n2], info) ! 2 fields of global size n1, n2
|
||||
! call nested_matrix%ins(1,1, n, rows, cols, vals, info) ! values of block (1,1) = A
|
||||
! call nested_matrix%ins(1,2, n, rows, cols, vals, info) ! values of block (1,2) = B^T
|
||||
! call nested_matrix%ins(2,1, n, rows, cols, vals, info) ! values of block (2,1) = B
|
||||
! ... ! (absent blocks = not inserted)
|
||||
! call nested_matrix%asb(info) ! assemble: builds a_glob, desc_glob
|
||||
!
|
||||
! ! from here on nested_matrix%a_glob and nested_matrix%desc_glob are an
|
||||
! ! ordinary distributed matrix/descriptor:
|
||||
! call psb_geall(x, nested_matrix%desc_glob, info)
|
||||
! call psb_krylov('CG', nested_matrix%a_glob, prec, b, x, eps, nested_matrix%desc_glob, info, ...)
|
||||
!
|
||||
! Indices: in ins(block_row, block_col, ...) the rows live in the index space of
|
||||
! field block_row, the columns in the index space of field block_col (GLOBAL
|
||||
! field indices, 1..field_size). Each process inserts only the rows it owns
|
||||
! (PSBLAS convention). Off-diagonal blocks may be rectangular.
|
||||
!
|
||||
! NOTE: after asb the object holds consistent internal pointers (a_glob%a points
|
||||
! to block_storage / grid_desc): do not copy/move the object after assembly.
|
||||
!
|
||||
module psb_z_nest_builder_mod
|
||||
use psb_const_mod
|
||||
use psb_error_mod, only : psb_errpush
|
||||
use psb_penv_mod, only : psb_ctxt_type, psb_info
|
||||
use psb_desc_mod, only : psb_desc_type
|
||||
use psb_z_mat_mod, only : psb_zspmat_type
|
||||
use psb_z_base_mat_mod, only : psb_z_base_sparse_mat
|
||||
use psb_cd_tools_mod, only : psb_cdall, psb_cdins, psb_cdasb
|
||||
use psb_desc_nest_mod, only : psb_desc_nest_type
|
||||
use psb_z_nest_mat_mod, only : psb_z_nest_sparse_mat
|
||||
use psb_z_nest_base_mat_mod, only : psb_z_nest_base_mat, psb_z_nest_base_setup
|
||||
use psb_cd_nest_tools_mod, only : psb_cd_nest_compose
|
||||
use psb_z_nest_tools_mod, only : psb_z_nest_rect_block
|
||||
implicit none
|
||||
|
||||
! growing triplet buffer for a single block
|
||||
type :: psb_z_nest_block_buffer
|
||||
integer(psb_ipk_) :: n_entries = 0
|
||||
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_dpk_), allocatable :: entry_vals(:)
|
||||
end type psb_z_nest_block_buffer
|
||||
|
||||
type :: psb_z_nest_matrix
|
||||
type(psb_ctxt_type) :: context
|
||||
integer(psb_ipk_) :: n_fields = 0
|
||||
logical :: assembled = .false.
|
||||
! construction state
|
||||
type(psb_desc_type), allocatable :: field_desc(:) ! one descriptor per field
|
||||
type(psb_z_nest_block_buffer), allocatable :: block_buffer(:,:) ! triplets per block (i,j)
|
||||
! products (owned; the pointers in a_glob%a point in here)
|
||||
type(psb_z_nest_sparse_mat) :: block_storage
|
||||
type(psb_desc_nest_type) :: grid_desc
|
||||
type(psb_zspmat_type) :: a_glob ! the matrix to hand to Krylov
|
||||
type(psb_desc_type) :: desc_glob ! the global descriptor
|
||||
contains
|
||||
procedure, pass(op) :: init => psb_z_nest_op_init
|
||||
procedure, pass(op) :: ins => psb_z_nest_op_ins
|
||||
procedure, pass(op) :: asb => psb_z_nest_op_asb
|
||||
procedure, pass(op) :: free => psb_z_nest_op_free
|
||||
! user-friendly queries on the field row distribution (no descriptor
|
||||
! jargon needed: these replace field_desc(i)%get_local_rows() / %l2g(...))
|
||||
procedure, pass(op) :: get_owned_rows => psb_z_nest_op_get_owned_rows
|
||||
procedure, pass(op) :: get_owned_row_count => psb_z_nest_op_get_owned_row_count
|
||||
end type psb_z_nest_matrix
|
||||
|
||||
private
|
||||
public :: psb_z_nest_matrix
|
||||
|
||||
contains
|
||||
|
||||
! init: create one descriptor per field (block distribution from the global sizes)
|
||||
subroutine psb_z_nest_op_init(op, context, field_sizes, info)
|
||||
class(psb_z_nest_matrix), intent(inout) :: op
|
||||
type(psb_ctxt_type), intent(in) :: context
|
||||
integer(psb_lpk_), intent(in) :: field_sizes(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: my_rank, num_procs, n_fields, i_field, field_local_rows
|
||||
integer(psb_lpk_) :: field_global_size
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_z_nest_op_init'
|
||||
|
||||
call psb_info(context, my_rank, num_procs)
|
||||
n_fields = size(field_sizes)
|
||||
op%context = context
|
||||
op%n_fields = n_fields
|
||||
op%assembled = .false.
|
||||
|
||||
allocate(op%field_desc(n_fields), op%block_buffer(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
|
||||
do i_field = 1, n_fields
|
||||
field_global_size = field_sizes(i_field)
|
||||
! block distribution: field_global_size rows over num_procs processes (total size invariant)
|
||||
field_local_rows = int(field_global_size / int(num_procs, psb_lpk_), psb_ipk_)
|
||||
if (int(my_rank, psb_lpk_) < mod(field_global_size, int(num_procs, psb_lpk_))) &
|
||||
& field_local_rows = field_local_rows + 1
|
||||
call psb_cdall(context, op%field_desc(i_field), info, nl=field_local_rows)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdall'); return
|
||||
end if
|
||||
end do
|
||||
end subroutine psb_z_nest_op_init
|
||||
|
||||
! ins: accumulate the triplets into block (block_row,block_col) and register the
|
||||
! columns (field block_col index space) into that descriptor's union halo
|
||||
subroutine psb_z_nest_op_ins(op, block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info)
|
||||
class(psb_z_nest_matrix), intent(inout) :: op
|
||||
integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_dpk_), intent(in) :: entry_vals(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_z_nest_op_ins'
|
||||
|
||||
if (op%assembled) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='operator already assembled'); return
|
||||
end if
|
||||
if (block_row < 1 .or. block_row > op%n_fields .or. &
|
||||
& block_col < 1 .or. block_col > op%n_fields) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='block index out of range'); return
|
||||
end if
|
||||
if (n_entries <= 0) return
|
||||
|
||||
call block_buffer_append(op%block_buffer(block_row,block_col), n_entries, &
|
||||
& entry_rows, entry_cols, entry_vals, info)
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
|
||||
! the columns of block (block_row,block_col) live in field block_col ->
|
||||
! register their indices into that descriptor's union halo
|
||||
! (this also applies when block_col == block_row)
|
||||
call psb_cdins(n_entries, entry_cols(1:n_entries), op%field_desc(block_col), info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins'); return
|
||||
end if
|
||||
end subroutine psb_z_nest_op_ins
|
||||
|
||||
! asb: assemble the descriptors, build the blocks, compose the global
|
||||
! descriptor, set up the operator and wrap it into a_glob.
|
||||
! The optional type ('CSR'/'CSC'/'COO', default 'CSR') or mold (any
|
||||
! class extending psb_z_base_sparse_mat, e.g. the psb_ext ELL/HLL or
|
||||
! the psb_cuda device formats) selects the storage format of the blocks.
|
||||
subroutine psb_z_nest_op_asb(op, info, type, mold)
|
||||
class(psb_z_nest_matrix), intent(inout), target :: op
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: mold
|
||||
|
||||
type(psb_z_nest_base_mat) :: nest_operator
|
||||
integer(psb_ipk_) :: n_fields, i_field, j_field
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_z_nest_op_asb'
|
||||
n_fields = op%n_fields
|
||||
|
||||
! 1) assemble the per-field descriptors (with the union halo accumulated in ins)
|
||||
do i_field = 1, n_fields
|
||||
call psb_cdasb(op%field_desc(i_field), info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb'); return
|
||||
end if
|
||||
end do
|
||||
|
||||
! 2) build the local blocks (generally rectangular) from the triplets
|
||||
op%block_storage%nrblocks = n_fields
|
||||
op%block_storage%ncblocks = n_fields
|
||||
allocate(op%block_storage%mats(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
if (op%block_buffer(i_field,j_field)%n_entries > 0) then
|
||||
call psb_z_nest_rect_block(op%block_storage%mats(i_field,j_field), &
|
||||
& op%block_buffer(i_field,j_field)%n_entries, &
|
||||
& op%block_buffer(i_field,j_field)%entry_rows, &
|
||||
& op%block_buffer(i_field,j_field)%entry_cols, &
|
||||
& op%block_buffer(i_field,j_field)%entry_vals, &
|
||||
& op%field_desc(i_field), op%field_desc(j_field), info, &
|
||||
& type=type, mold=mold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='rect_block'); return
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
! 3) descriptor grid: descs(i,j) = descriptor of field j
|
||||
op%grid_desc%nrblocks = n_fields
|
||||
op%grid_desc%ncblocks = n_fields
|
||||
allocate(op%grid_desc%descs(n_fields,n_fields), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
call op%field_desc(j_field)%clone(op%grid_desc%descs(i_field,j_field), info)
|
||||
end do
|
||||
end do
|
||||
|
||||
! 4) composed global descriptor + operator setup
|
||||
call psb_cd_nest_compose(op%grid_desc, op%desc_glob, info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='cd_nest_compose'); return
|
||||
end if
|
||||
call psb_z_nest_base_setup(nest_operator, op%block_storage, op%grid_desc, op%desc_glob, info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='nest_base_setup'); return
|
||||
end if
|
||||
|
||||
! 5) wrap into the standard matrix object (the pointers keep pointing at op%*)
|
||||
allocate(op%a_glob%a, source=nest_operator, stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
|
||||
end if
|
||||
call op%a_glob%set_nrows(op%desc_glob%get_local_rows())
|
||||
call op%a_glob%set_ncols(op%desc_glob%get_local_cols())
|
||||
call op%a_glob%set_asb()
|
||||
|
||||
! 6) the triplet buffers are no longer needed
|
||||
do j_field = 1, n_fields
|
||||
do i_field = 1, n_fields
|
||||
call block_buffer_free(op%block_buffer(i_field,j_field))
|
||||
end do
|
||||
end do
|
||||
op%assembled = .true.
|
||||
end subroutine psb_z_nest_op_asb
|
||||
|
||||
! free: release everything
|
||||
subroutine psb_z_nest_op_free(op, info)
|
||||
class(psb_z_nest_matrix), intent(inout) :: op
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i_field, j_field, local_info
|
||||
|
||||
info = psb_success_
|
||||
if (allocated(op%block_buffer)) then
|
||||
do j_field = 1, size(op%block_buffer,2)
|
||||
do i_field = 1, size(op%block_buffer,1)
|
||||
call block_buffer_free(op%block_buffer(i_field,j_field))
|
||||
end do
|
||||
end do
|
||||
deallocate(op%block_buffer, stat=local_info)
|
||||
end if
|
||||
if (op%assembled) then
|
||||
call op%a_glob%free()
|
||||
call op%desc_glob%free(local_info)
|
||||
call op%grid_desc%free(local_info)
|
||||
end if
|
||||
if (allocated(op%field_desc)) then
|
||||
do i_field = 1, size(op%field_desc)
|
||||
call op%field_desc(i_field)%free(local_info)
|
||||
end do
|
||||
deallocate(op%field_desc, stat=local_info)
|
||||
end if
|
||||
op%n_fields = 0
|
||||
op%assembled = .false.
|
||||
end subroutine psb_z_nest_op_free
|
||||
|
||||
! get_owned_rows: GLOBAL indices (in the field index space, 1..field size)
|
||||
! of the rows of field i_field owned by this process. This is the list of
|
||||
! rows the process is expected to insert through ins:
|
||||
!
|
||||
! my_rows = nested_matrix%get_owned_rows(1)
|
||||
! do k = 1, size(my_rows)
|
||||
! global_row = my_rows(k)
|
||||
! ...
|
||||
!
|
||||
! An empty array is returned for an out-of-range field index.
|
||||
function psb_z_nest_op_get_owned_rows(op, i_field) result(owned_global_rows)
|
||||
class(psb_z_nest_matrix), intent(in) :: op
|
||||
integer(psb_ipk_), intent(in) :: i_field
|
||||
integer(psb_lpk_), allocatable :: owned_global_rows(:)
|
||||
|
||||
if ((i_field < 1) .or. (i_field > op%n_fields) .or. &
|
||||
& (.not. allocated(op%field_desc))) then
|
||||
allocate(owned_global_rows(0))
|
||||
return
|
||||
end if
|
||||
owned_global_rows = op%field_desc(i_field)%get_global_indices(owned=.true.)
|
||||
end function psb_z_nest_op_get_owned_rows
|
||||
|
||||
! get_owned_row_count: how many rows of field i_field this process owns
|
||||
function psb_z_nest_op_get_owned_row_count(op, i_field) result(owned_row_count)
|
||||
class(psb_z_nest_matrix), intent(in) :: op
|
||||
integer(psb_ipk_), intent(in) :: i_field
|
||||
integer(psb_ipk_) :: owned_row_count
|
||||
|
||||
owned_row_count = 0
|
||||
if ((i_field < 1) .or. (i_field > op%n_fields) .or. &
|
||||
& (.not. allocated(op%field_desc))) return
|
||||
owned_row_count = op%field_desc(i_field)%get_local_rows()
|
||||
end function psb_z_nest_op_get_owned_row_count
|
||||
|
||||
!-----------------------------------------------------------------
|
||||
! private helpers: growing triplet buffer
|
||||
!-----------------------------------------------------------------
|
||||
subroutine block_buffer_append(buffer, n_entries, entry_rows, entry_cols, entry_vals, info)
|
||||
type(psb_z_nest_block_buffer), intent(inout) :: buffer
|
||||
integer(psb_ipk_), intent(in) :: n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_dpk_), intent(in) :: entry_vals(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: required_size
|
||||
|
||||
info = psb_success_
|
||||
required_size = buffer%n_entries + n_entries
|
||||
call ensure_capacity_lpk(buffer%entry_rows, required_size, info); if (info /= 0) return
|
||||
call ensure_capacity_lpk(buffer%entry_cols, required_size, info); if (info /= 0) return
|
||||
call ensure_capacity_val(buffer%entry_vals, required_size, info); if (info /= 0) return
|
||||
buffer%entry_rows(buffer%n_entries+1:required_size) = entry_rows(1:n_entries)
|
||||
buffer%entry_cols(buffer%n_entries+1:required_size) = entry_cols(1:n_entries)
|
||||
buffer%entry_vals(buffer%n_entries+1:required_size) = entry_vals(1:n_entries)
|
||||
buffer%n_entries = required_size
|
||||
end subroutine block_buffer_append
|
||||
|
||||
subroutine ensure_capacity_lpk(array, required_size, info)
|
||||
integer(psb_lpk_), allocatable, intent(inout) :: array(:)
|
||||
integer(psb_ipk_), intent(in) :: required_size
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_lpk_), allocatable :: grown(:)
|
||||
integer(psb_ipk_) :: capacity
|
||||
|
||||
info = 0
|
||||
if (.not. allocated(array)) then
|
||||
allocate(array(max(required_size,16)), stat=info); return
|
||||
end if
|
||||
capacity = size(array)
|
||||
if (required_size <= capacity) return
|
||||
allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return
|
||||
grown(1:capacity) = array(1:capacity)
|
||||
call move_alloc(grown, array)
|
||||
end subroutine ensure_capacity_lpk
|
||||
|
||||
subroutine ensure_capacity_val(array, required_size, info)
|
||||
complex(psb_dpk_), allocatable, intent(inout) :: array(:)
|
||||
integer(psb_ipk_), intent(in) :: required_size
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), allocatable :: grown(:)
|
||||
integer(psb_ipk_) :: capacity
|
||||
|
||||
info = 0
|
||||
if (.not. allocated(array)) then
|
||||
allocate(array(max(required_size,16)), stat=info); return
|
||||
end if
|
||||
capacity = size(array)
|
||||
if (required_size <= capacity) return
|
||||
allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return
|
||||
grown(1:capacity) = array(1:capacity)
|
||||
call move_alloc(grown, array)
|
||||
end subroutine ensure_capacity_val
|
||||
|
||||
subroutine block_buffer_free(buffer)
|
||||
type(psb_z_nest_block_buffer), intent(inout) :: buffer
|
||||
if (allocated(buffer%entry_rows)) deallocate(buffer%entry_rows)
|
||||
if (allocated(buffer%entry_cols)) deallocate(buffer%entry_cols)
|
||||
if (allocated(buffer%entry_vals)) deallocate(buffer%entry_vals)
|
||||
buffer%n_entries = 0
|
||||
end subroutine block_buffer_free
|
||||
|
||||
end module psb_z_nest_builder_mod
|
||||
@ -0,0 +1,364 @@
|
||||
!
|
||||
! 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_z_nest_tools_mod
|
||||
! Author: Simone Staccone (Stack-1)
|
||||
!
|
||||
! Nested-specific assembly wrappers for PSBLAS3 — double precision matrix and vector routines
|
||||
!
|
||||
|
||||
module psb_z_nest_tools_mod
|
||||
use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_dpk_, psb_success_, psb_err_alloc_dealloc_, &
|
||||
psb_err_invalid_input_, psb_err_from_subroutine_, &
|
||||
psb_dupl_add_, psb_dupl_ovwrt_, psb_dupl_err_, psb_ctxt_type
|
||||
use psb_error_mod, only : psb_errpush
|
||||
use psb_z_tools_mod, only : psb_spall, psb_spins, psb_spasb, psb_spfree, psb_sprn, &
|
||||
psb_geall, psb_geins, psb_geasb, psb_gefree
|
||||
use psb_desc_nest_mod, only : psb_desc_nest_type
|
||||
use psb_z_nest_mat_mod, only : psb_z_nest_sparse_mat
|
||||
use psb_z_mat_mod, only : psb_zspmat_type
|
||||
use psb_z_base_mat_mod, only : psb_z_coo_sparse_mat, psb_z_base_sparse_mat
|
||||
use psb_desc_mod, only : psb_desc_type
|
||||
implicit none
|
||||
|
||||
private
|
||||
|
||||
public :: psb_spall_nest, psb_spins_nest, psb_spasb_nest, psb_spfree_nest, psb_sprn_nest, &
|
||||
psb_z_nest_rect_block
|
||||
|
||||
contains
|
||||
|
||||
! Allocates all (nrblocks x ncblocks) sparse matrix blocks
|
||||
! and marks all as present. psb_spins_nest lazy-allocates individual
|
||||
! blocks on first insertion; call psb_spall_nest instead when the
|
||||
! full block structure is known up front.
|
||||
|
||||
subroutine psb_spall_nest(a_nest, desc_nest, info, nnz)
|
||||
type(psb_z_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: nnz
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spall_nest'
|
||||
|
||||
a_nest%nrblocks = desc_nest%nrblocks
|
||||
a_nest%ncblocks = desc_nest%ncblocks
|
||||
|
||||
if (.not. allocated(a_nest%mats)) then
|
||||
allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
local_info = psb_success_
|
||||
if (present(nnz)) then
|
||||
call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, nnz=nnz)
|
||||
else
|
||||
call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall')
|
||||
return
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_spall_nest
|
||||
|
||||
|
||||
! Inserts nz entries into block (blk_i, blk_j) of the nested matrix.
|
||||
! The block is lazy-allocated on first insertion if psb_spall_nest
|
||||
! was not called first.
|
||||
|
||||
subroutine psb_spins_nest(block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, a_nest, desc_nest, info)
|
||||
integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries
|
||||
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
|
||||
complex(psb_dpk_), intent(in) :: entry_vals(:)
|
||||
type(psb_z_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: nnz_estimate
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spins_nest'
|
||||
|
||||
if (n_entries == 0) return
|
||||
|
||||
if (block_row < 1 .or. block_row > a_nest%nrblocks .or. &
|
||||
block_col < 1 .or. block_col > a_nest%ncblocks) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='invalid block indices')
|
||||
return
|
||||
end if
|
||||
|
||||
if (.not. allocated(a_nest%mats)) then
|
||||
allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not. allocated(a_nest%mats(block_row, block_col)%a)) then
|
||||
! Estimate nnz: use n_entries + 50% buffer for future insertions
|
||||
nnz_estimate = max(n_entries, 10) + n_entries / 2
|
||||
call psb_spall(a_nest%mats(block_row, block_col), &
|
||||
desc_nest%descs(block_row, block_col), info, nnz=nnz_estimate)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall')
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_spins(n_entries, entry_rows, entry_cols, entry_vals, a_nest%mats(block_row, block_col), &
|
||||
desc_nest%descs(block_row, block_col), info)
|
||||
if (info /= psb_success_) &
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spins')
|
||||
|
||||
end subroutine psb_spins_nest
|
||||
|
||||
! Calls psb_spasb on all present block matrices.
|
||||
! Must be called after psb_cdasb_nest.
|
||||
|
||||
subroutine psb_spasb_nest(a_nest, desc_nest, info, dupl)
|
||||
type(psb_z_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: dupl
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, dupl_mode, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spasb_nest'
|
||||
dupl_mode = psb_dupl_add_
|
||||
if (present(dupl)) dupl_mode = dupl
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
if (dupl_mode == psb_dupl_add_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_add_)
|
||||
else if (dupl_mode == psb_dupl_ovwrt_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_ovwrt_)
|
||||
else if (dupl_mode == psb_dupl_err_) then
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info, dupl=psb_dupl_err_)
|
||||
else
|
||||
call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), &
|
||||
local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spasb')
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_spasb_nest
|
||||
|
||||
! Calls psb_spfree on every present block, then deallocates the
|
||||
! mats array and resets nrblocks/ncblocks to 0.
|
||||
|
||||
subroutine psb_spfree_nest(a_nest, desc_nest, info)
|
||||
type(psb_z_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_spfree_nest'
|
||||
|
||||
if (allocated(a_nest%mats)) then
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
call psb_spfree(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
if (local_info /= psb_success_ .and. info == psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spfree')
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
deallocate(a_nest%mats, stat=local_info)
|
||||
if (local_info /= 0 .and. info == psb_success_) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info, name)
|
||||
end if
|
||||
end if
|
||||
|
||||
a_nest%nrblocks = 0
|
||||
a_nest%ncblocks = 0
|
||||
|
||||
end subroutine psb_spfree_nest
|
||||
|
||||
! Calls psb_sprn on every present block matrix, resetting it to
|
||||
! the build state while preserving the sparsity pattern.
|
||||
|
||||
subroutine psb_sprn_nest(a_nest, desc_nest, info, clear)
|
||||
type(psb_z_nest_sparse_mat), intent(inout) :: a_nest
|
||||
type(psb_desc_nest_type), intent(in) :: desc_nest
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: clear
|
||||
|
||||
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
|
||||
character(len=20) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_sprn_nest'
|
||||
|
||||
if (.not. allocated(a_nest%mats)) return
|
||||
|
||||
do i_block_row = 1, a_nest%nrblocks
|
||||
do j_block_col = 1, a_nest%ncblocks
|
||||
if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then
|
||||
local_info = psb_success_
|
||||
if (present(clear)) then
|
||||
call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, clear=clear)
|
||||
else
|
||||
call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info)
|
||||
end if
|
||||
if (local_info /= psb_success_ .and. info == psb_success_) then
|
||||
info = local_info
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_sprn')
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
end subroutine psb_sprn_nest
|
||||
|
||||
|
||||
|
||||
! psb_z_nest_rect_block
|
||||
!
|
||||
! Build a local GENERAL (possibly rectangular) block A(i,j) of a nested
|
||||
! operator, with rows in field i and columns in field j (field i /= field j,
|
||||
! |field i| /= |field j| allowed). Rows are localized against the field-i
|
||||
! (row) descriptor, columns against the field-j (column) descriptor — which
|
||||
! must already carry the union halo of column j (cdall + cdins(all column-j
|
||||
! blocks' columns) + cdasb). The result is a CSR block of shape
|
||||
! (field-i owned rows) x (field-j local cols incl. halo)
|
||||
! consumable directly by the nested csmv (psb_z_nest_base_mat).
|
||||
!
|
||||
! A single-descriptor psb_spall/psb_spasb cannot express row-field /= col-field
|
||||
! (it would force rows and columns into the same index space), hence the
|
||||
! explicit COO build with separate row/column localization.
|
||||
!
|
||||
! Arguments (this process's local contribution):
|
||||
! blk (out) the assembled block (CSR)
|
||||
! nz number of local entries
|
||||
! ia_glob(:) GLOBAL field-i row indices (owned by this process)
|
||||
! ja_glob(:) GLOBAL field-j column indices
|
||||
! val(:) values
|
||||
! desc_row field-i descriptor (rows)
|
||||
! desc_col field-j descriptor (columns, with union halo)
|
||||
!
|
||||
subroutine psb_z_nest_rect_block(blk, nz, ia_glob, ja_glob, val, desc_row, desc_col, info, type, mold)
|
||||
type(psb_zspmat_type), intent(out) :: blk
|
||||
integer(psb_ipk_), intent(in) :: nz
|
||||
integer(psb_lpk_), intent(in) :: ia_glob(:), ja_glob(:)
|
||||
complex(psb_dpk_), intent(in) :: val(:)
|
||||
type(psb_desc_type), intent(in) :: desc_row, desc_col
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: type ! base storage format (default 'CSR')
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: mold ! any format, e.g. psb_ext ELL/HLL
|
||||
|
||||
type(psb_z_coo_sparse_mat) :: coo_block
|
||||
integer(psb_ipk_) :: k_entry, n_loc_rows, n_loc_cols, loc_row, loc_col
|
||||
character(len=24) :: name
|
||||
|
||||
info = psb_success_
|
||||
name = 'psb_z_nest_rect_block'
|
||||
|
||||
n_loc_rows = desc_row%get_local_rows() ! owned rows of field i
|
||||
n_loc_cols = desc_col%get_local_cols() ! field-j local cols (owned + halo)
|
||||
|
||||
call coo_block%allocate(n_loc_rows, n_loc_cols, nz)
|
||||
do k_entry = 1, nz
|
||||
call desc_row%g2l(ia_glob(k_entry), loc_row, info)
|
||||
if (info /= 0 .or. loc_row < 1 .or. loc_row > n_loc_rows) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='row not owned / not localizable')
|
||||
return
|
||||
end if
|
||||
call desc_col%g2l(ja_glob(k_entry), loc_col, info)
|
||||
if (info /= 0 .or. loc_col < 1 .or. loc_col > n_loc_cols) then
|
||||
info = psb_err_invalid_input_
|
||||
call psb_errpush(info, name, a_err='column not in field-j descriptor (missing from union halo)')
|
||||
return
|
||||
end if
|
||||
coo_block%ia(k_entry) = loc_row
|
||||
coo_block%ja(k_entry) = loc_col
|
||||
coo_block%val(k_entry) = val(k_entry)
|
||||
end do
|
||||
call coo_block%set_nzeros(nz)
|
||||
call coo_block%set_dupl(psb_dupl_add_)
|
||||
call coo_block%fix(info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix'); return
|
||||
end if
|
||||
call blk%mv_from(coo_block)
|
||||
if (present(mold)) then
|
||||
call blk%cscnv(info, mold=mold)
|
||||
else if (present(type)) then
|
||||
call blk%cscnv(info, type=type)
|
||||
else
|
||||
call blk%cscnv(info, type='CSR')
|
||||
end if
|
||||
if (info /= 0) then
|
||||
call psb_errpush(psb_err_from_subroutine_, name, a_err='cscnv'); return
|
||||
end if
|
||||
end subroutine psb_z_nest_rect_block
|
||||
|
||||
end module psb_z_nest_tools_mod
|
||||
Loading…
Reference in New Issue