fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-21 05:12:13 +00:00
Code Issues Packages Projects Releases Wiki Activity

[ADD] Nested (MATNEST-style) block matrix support and tests

Browse Source 
Add a block-structured distributed operator that presents itself to Krylov
solvers and preconditioners as a single ordinary distributed matrix (the
PSBLAS analogue of PETSc MATNEST), targeting saddle-point systems
M = [[A, B^T], [B, 0]] with possibly rectangular sub-blocks.

Library (base/modules):
- psb_desc_nest_mod, psb_d_nest_mat_mod: grid of per-field descriptors and
  per-block sparse storage.
- psb_d_nest_base_mat_mod: psb_d_nest_base_mat, the operator extending
  psb_d_base_sparse_mat (local csmv, free, field-split hooks for a future
  block preconditioner).
- psb_cd_nest_tools_mod / psb_d_nest_tools_mod: composed global descriptor
  with union halo (psb_cd_nest_compose) and rectangular local block builder
  (psb_d_nest_rect_block), plus the per-block assembly wrappers.
- psb_d_nest_builder_mod: psb_d_nest_matrix, the user frontend with the
  init/ins/asb/free pattern hiding all descriptor/halo/compose/setup
  boilerplate.
- psb_d_nest_mod: umbrella module (use psb_d_nest_mod).

Remove the earlier bespoke per-block prototype (comm/psblas/vect modules and
the pde_nest_psblas test) superseded by the single MATNEST design.

Tests (test/nested): glob (square operator vs monolithic CSR oracle), rect
(genuinely rectangular blocks), cg (low-level path, ill-conditioned SPD
red-black Laplacian solved with standard CG), builder (same solve via the
utility), plus a README describing the design and usage. All pass serially
and in parallel, with results invariant to the process count.

Build hooks updated (autotools Makefiles + CMakeLists); the nested tests are
relocated out of test/pdegen into test/nested.

Author: Simone Staccone (Stack-1)
This commit is contained in:
Stack-1
2026-06-11 16:53:46 +02:00
parent 784c3cc0b4
commit acdd2e9eb5
23 changed files with 2384 additions and 1889 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/tools/psb_cd_nest_tools_mod.F90
+202 -75
View File
@@ -29,6 +29,9 @@
! POSSIBILITY OF SUCH DAMAGE.
!
!
! Module: psb_cd_nest_tools_mod
! Author: Simone Staccone (Stack-1)
!
! Nested-specific assembly wrappers for PSBLAS3 — descriptor routines
!
@@ -39,12 +42,14 @@ module psb_cd_nest_tools_mod
use psb_error_mod, only : psb_errpush
use psb_cd_tools_mod, only : psb_cdall, psb_cdasb, psb_cdins, psb_cdcpy, psb_cdprt
use psb_desc_nest_mod, only : psb_desc_nest_type
use psb_desc_mod, only : psb_desc_type
implicit none
private
public :: psb_cdall_nest, psb_cdins_nest, psb_cdins_nest_rc, &
psb_cdasb_nest, psb_cdfree_nest, psb_cdcpy_nest, psb_cdprt_nest
psb_cdasb_nest, psb_cdfree_nest, psb_cdcpy_nest, psb_cdprt_nest, &
psb_cd_nest_compose
! Column-only form: (blk_j, nz, ja, desc_nest, info [,mask, lidx])
! Row+column form: (blk_i, blk_j, nz, ia, ja, desc_nest, info)
@@ -86,29 +91,29 @@ contains
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nrblocks, ncblocks, nl
integer(psb_ipk_) :: i, j, nr, nc, nl_
integer(psb_ipk_) :: i_block_row, j_block_col, n_block_rows, n_block_cols, local_rows
character(len=20) :: name
info = psb_success_
name = 'psb_cdall_nest'
! Set default dimensions
nr = 2
nc = 2
if (present(nrblocks)) nr = nrblocks
if (present(ncblocks)) nc = ncblocks
n_block_rows = 2
n_block_cols = 2
if (present(nrblocks)) n_block_rows = nrblocks
if (present(ncblocks)) n_block_cols = ncblocks
if (.not. present(nl)) then
info = psb_err_no_optional_arg_
call psb_errpush(info, name, a_err='nl (local row count)')
return
end if
nl_ = nl
local_rows = nl
! Allocate nested descriptor structure
desc_nest%nrblocks = nr
desc_nest%ncblocks = nc
allocate(desc_nest%descs(nr, nc), stat=info)
desc_nest%nrblocks = n_block_rows
desc_nest%ncblocks = n_block_cols
allocate(desc_nest%descs(n_block_rows, n_block_cols), stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
@@ -120,9 +125,9 @@ contains
! psb_cdasb_nest assembles both the original and the clone the shared
! base_desc is rebuilt twice, corrupting the global-to-local mapping of
! every block in that row. Independent allocations avoid this entirely.
do i = 1, nr
do j = 1, nc
call psb_cdall(ctxt, desc_nest%descs(i, j), info, nl=nl_)
do i_block_row = 1, n_block_rows
do j_block_col = 1, n_block_cols
call psb_cdall(ctxt, desc_nest%descs(i_block_row, j_block_col), info, nl=local_rows)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_, name)
return
@@ -135,9 +140,9 @@ contains
#if defined(PSB_IPK4) && defined(PSB_LPK8)
! psb_cdins_nest_rc_sub: row+col form, ipk_ nz — only when ipk_ /= lpk_
subroutine psb_cdins_nest_rc_sub(blk_i, blk_j, nz, ia, ja, desc_nest, info)
integer(psb_ipk_), intent(in) :: blk_i, blk_j, nz
integer(psb_lpk_), intent(in) :: ia(:), ja(:)
subroutine psb_cdins_nest_rc_sub(block_row, block_col, n_entries, entry_rows, entry_cols, desc_nest, info)
integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
type(psb_desc_nest_type), intent(inout) :: desc_nest
integer(psb_ipk_), intent(out) :: info
@@ -146,16 +151,16 @@ contains
info = psb_success_
name = 'psb_cdins_nest'
if (nz == 0) return
if (n_entries == 0) return
if (blk_i < 1 .or. blk_i > desc_nest%nrblocks .or. &
blk_j < 1 .or. blk_j > desc_nest%ncblocks) then
if (block_row < 1 .or. block_row > desc_nest%nrblocks .or. &
block_col < 1 .or. block_col > desc_nest%ncblocks) then
info = psb_err_invalid_input_
call psb_errpush(info, name, a_err='invalid block indices')
return
end if
call psb_cdins(nz, ia, ja, desc_nest%descs(blk_i, blk_j), info)
call psb_cdins(n_entries, entry_rows, entry_cols, desc_nest%descs(block_row, block_col), info)
if (info /= psb_success_) &
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins')
@@ -163,45 +168,45 @@ contains
! psb_cdins_nest_c: col-only form, ipk_ nz — only when ipk_ /= lpk_
subroutine psb_cdins_nest_c(blk_j, nz, ja, desc_nest, info, mask, lidx)
integer(psb_ipk_), intent(in) :: blk_j, nz
integer(psb_lpk_), intent(in) :: ja(:)
subroutine psb_cdins_nest_c(block_col, n_entries, entry_cols, desc_nest, info, mask, lidx)
integer(psb_ipk_), intent(in) :: block_col, n_entries
integer(psb_lpk_), intent(in) :: entry_cols(:)
type(psb_desc_nest_type), intent(inout) :: desc_nest
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional, target :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, linfo
integer(psb_ipk_) :: i_block_row, local_info
character(len=20) :: name
info = psb_success_
name = 'psb_cdins_nest'
if (nz == 0) return
if (n_entries == 0) return
if (blk_j < 1 .or. blk_j > desc_nest%ncblocks) then
if (block_col < 1 .or. block_col > desc_nest%ncblocks) then
info = psb_err_invalid_input_
call psb_errpush(info, name, a_err='invalid block column index')
return
end if
do i = 1, desc_nest%nrblocks
linfo = psb_success_
do i_block_row = 1, desc_nest%nrblocks
local_info = psb_success_
if (present(mask)) then
if (present(lidx)) then
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo, mask=mask, lidx=lidx)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, mask=mask, lidx=lidx)
else
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo, mask=mask)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, mask=mask)
end if
else
if (present(lidx)) then
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo, lidx=lidx)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, lidx=lidx)
else
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info)
end if
end if
if (linfo /= psb_success_ .and. info == psb_success_) then
info = linfo
if (local_info /= psb_success_ .and. info == psb_success_) then
info = local_info
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins')
end if
end do
@@ -215,9 +220,9 @@ contains
! When entries in block (blk_i, blk_j) reference columns owned by other
! processes, use the col-only form afterwards to broadcast those column
! indices across all row-blocks in block-col blk_j.
subroutine psb_lcdins_nest_rc(blk_i, blk_j, nz, ia, ja, desc_nest, info)
integer(psb_ipk_), intent(in) :: blk_i, blk_j
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:)
subroutine psb_lcdins_nest_rc(block_row, block_col, n_entries, entry_rows, entry_cols, desc_nest, info)
integer(psb_ipk_), intent(in) :: block_row, block_col
integer(psb_lpk_), intent(in) :: n_entries, entry_rows(:), entry_cols(:)
type(psb_desc_nest_type), intent(inout) :: desc_nest
integer(psb_ipk_), intent(out) :: info
@@ -226,16 +231,16 @@ contains
info = psb_success_
name = 'psb_cdins_nest'
if (nz == 0) return
if (n_entries == 0) return
if (blk_i < 1 .or. blk_i > desc_nest%nrblocks .or. &
blk_j < 1 .or. blk_j > desc_nest%ncblocks) then
if (block_row < 1 .or. block_row > desc_nest%nrblocks .or. &
block_col < 1 .or. block_col > desc_nest%ncblocks) then
info = psb_err_invalid_input_
call psb_errpush(info, name, a_err='invalid block indices')
return
end if
call psb_cdins(nz, ia, ja, desc_nest%descs(blk_i, blk_j), info)
call psb_cdins(n_entries, entry_rows, entry_cols, desc_nest%descs(block_row, block_col), info)
if (info /= psb_success_) &
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins')
@@ -247,45 +252,45 @@ contains
! Registers nz global column indices ja into the descriptor for
! block column blk_j across all row-blocks (descs(i, blk_j) for
! i = 1..nrblocks). mask and lidx are forwarded to psb_cdins.
subroutine psb_lcdins_nest_c(blk_j, nz, ja, desc_nest, info, mask, lidx)
integer(psb_ipk_), intent(in) :: blk_j
integer(psb_lpk_), intent(in) :: nz, ja(:)
subroutine psb_lcdins_nest_c(block_col, n_entries, entry_cols, desc_nest, info, mask, lidx)
integer(psb_ipk_), intent(in) :: block_col
integer(psb_lpk_), intent(in) :: n_entries, entry_cols(:)
type(psb_desc_nest_type), intent(inout) :: desc_nest
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional, target :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, linfo
integer(psb_ipk_) :: i_block_row, local_info
character(len=20) :: name
info = psb_success_
name = 'psb_cdins_nest'
if (nz == 0) return
if (n_entries == 0) return
if (blk_j < 1 .or. blk_j > desc_nest%ncblocks) then
if (block_col < 1 .or. block_col > desc_nest%ncblocks) then
info = psb_err_invalid_input_
call psb_errpush(info, name, a_err='invalid block column index')
return
end if
do i = 1, desc_nest%nrblocks
linfo = psb_success_
do i_block_row = 1, desc_nest%nrblocks
local_info = psb_success_
if (present(mask)) then
if (present(lidx)) then
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo, mask=mask, lidx=lidx)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, mask=mask, lidx=lidx)
else
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo, mask=mask)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, mask=mask)
end if
else
if (present(lidx)) then
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo, lidx=lidx)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, lidx=lidx)
else
call psb_cdins(nz, ja, desc_nest%descs(i, blk_j), linfo)
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info)
end if
end if
if (linfo /= psb_success_ .and. info == psb_success_) then
info = linfo
if (local_info /= psb_success_ .and. info == psb_success_) then
info = local_info
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins')
end if
end do
@@ -307,15 +312,15 @@ contains
type(psb_desc_nest_type), intent(inout) :: desc_nest
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
integer(psb_ipk_) :: i_block_row, j_block_col
character(len=20) :: name
info = psb_success_
name = 'psb_cdasb_nest'
do i = 1, desc_nest%nrblocks
do j = 1, desc_nest%ncblocks
call psb_cdasb(desc_nest%descs(i, j), info)
do i_block_row = 1, desc_nest%nrblocks
do j_block_col = 1, desc_nest%ncblocks
call psb_cdasb(desc_nest%descs(i_block_row, j_block_col), info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb')
return
@@ -368,7 +373,7 @@ contains
type(psb_desc_nest_type), intent(out) :: desc_out
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
integer(psb_ipk_) :: i_block_row, j_block_col
character(len=20) :: name
info = psb_success_
@@ -383,9 +388,9 @@ contains
return
end if
do i = 1, desc_in%nrblocks
do j = 1, desc_in%ncblocks
call psb_cdcpy(desc_in%descs(i, j), desc_out%descs(i, j), info)
do i_block_row = 1, desc_in%nrblocks
do j_block_col = 1, desc_in%ncblocks
call psb_cdcpy(desc_in%descs(i_block_row, j_block_col), desc_out%descs(i_block_row, j_block_col), info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdcpy')
return
@@ -415,37 +420,37 @@ contains
logical, intent(in), optional :: glob, short
integer(psb_ipk_), intent(in), optional :: verbosity
integer(psb_ipk_) :: i, j
integer(psb_ipk_) :: i_block_row, j_block_col
do i = 1, desc_nest%nrblocks
do j = 1, desc_nest%ncblocks
write(iout, '(a,i0,a,i0,a)') 'Block (', i, ',', j, '):'
do i_block_row = 1, desc_nest%nrblocks
do j_block_col = 1, desc_nest%ncblocks
write(iout, '(a,i0,a,i0,a)') 'Block (', i_block_row, ',', j_block_col, '):'
if (present(glob)) then
if (present(short)) then
if (present(verbosity)) then
call psb_cdprt(iout, desc_nest%descs(i,j), glob=glob, short=short, verbosity=verbosity)
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col), glob=glob, short=short, verbosity=verbosity)
else
call psb_cdprt(iout, desc_nest%descs(i,j), glob=glob, short=short)
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col), glob=glob, short=short)
end if
else
if (present(verbosity)) then
call psb_cdprt(iout, desc_nest%descs(i,j), glob=glob, verbosity=verbosity)
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col), glob=glob, verbosity=verbosity)
else
call psb_cdprt(iout, desc_nest%descs(i,j), glob=glob)
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col), glob=glob)
end if
end if
else
if (present(short)) then
if (present(verbosity)) then
call psb_cdprt(iout, desc_nest%descs(i,j), short=short, verbosity=verbosity)
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col), short=short, verbosity=verbosity)
else
call psb_cdprt(iout, desc_nest%descs(i,j), short=short)
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col), short=short)
end if
else
if (present(verbosity)) then
call psb_cdprt(iout, desc_nest%descs(i,j), verbosity=verbosity)
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col), verbosity=verbosity)
else
call psb_cdprt(iout, desc_nest%descs(i,j))
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col))
end if
end if
end if
@@ -454,4 +459,126 @@ contains
end subroutine psb_cdprt_nest
! psb_cd_nest_compose (P1 / step 6a)
!
! Compose the per-field block descriptors into a SINGLE global psb_desc_type
! describing the whole nested operator. The global index space is the
! concatenation of the field spaces:
!
! global index = offset_k + (field-k global index), offset_k = sum_{m<k} n_m
!
! Each process owns its slice of every field; the global halo is the union of
! the per-field halos, each remapped by its field offset. Once composed, the
! nested operator can be presented to Krylov/AMG4PSBLAS as a standard
! distributed matrix/vector (MATNEST-style).
!
! Assumes a square block structure (nrblocks == ncblocks); field k is taken to
! be column k, whose distribution and halo are read from descs(1,k) (all
! descs(i,k) for fixed k share the same column space).
!
subroutine psb_cd_nest_compose(desc_grid, desc_global, info)
type(psb_desc_nest_type), intent(in) :: desc_grid
type(psb_desc_type), intent(out) :: desc_global
integer(psb_ipk_), intent(out) :: info
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: n_fields, i_field, i_loc, n_owned, n_local, owned_count, halo_count
integer(psb_lpk_) :: global_idx
integer(psb_lpk_), allocatable :: field_offset(:), owned_global(:), halo_global(:)
character(len=24) :: name
info = psb_success_
name = 'psb_cd_nest_compose'
if (.not. allocated(desc_grid%descs)) then
info = psb_err_invalid_input_
call psb_errpush(info, name, a_err='nested descriptor not allocated')
return
end if
if (desc_grid%nrblocks /= desc_grid%ncblocks) then
info = psb_err_invalid_input_
call psb_errpush(info, name, a_err='nested block structure must be square')
return
end if
n_fields = desc_grid%ncblocks
ctxt = desc_grid%descs(1,1)%get_context()
! 1. field offsets in the global numbering
allocate(field_offset(n_fields+1), stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
end if
field_offset(1) = 0
do i_field = 1, n_fields
field_offset(i_field+1) = field_offset(i_field) + desc_grid%descs(1,i_field)%get_global_rows()
end do
! 2. local owned global indices: U_k { offset_k + l2g(owned of field i_field) }
owned_count = 0
do i_field = 1, n_fields
owned_count = owned_count + desc_grid%descs(1,i_field)%get_local_rows()
end do
allocate(owned_global(owned_count), stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
end if
owned_count = 0
do i_field = 1, n_fields
n_owned = desc_grid%descs(1,i_field)%get_local_rows()
do i_loc = 1, n_owned
call desc_grid%descs(1,i_field)%l2g(i_loc, global_idx, info)
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='l2g'); return
end if
owned_count = owned_count + 1
owned_global(owned_count) = field_offset(i_field) + global_idx
end do
end do
! 3. allocate the global descriptor with the concatenated ownership
call psb_cdall(ctxt, desc_global, info, vl=owned_global)
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdall'); return
end if
! 4. global halo: U_k { offset_k + l2g(halo of field i_field) }
! field-i_field halo local indices are local_rows+1 .. local_cols
halo_count = 0
do i_field = 1, n_fields
halo_count = halo_count + (desc_grid%descs(1,i_field)%get_local_cols() &
& - desc_grid%descs(1,i_field)%get_local_rows())
end do
if (halo_count > 0) then
allocate(halo_global(halo_count), stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return
end if
halo_count = 0
do i_field = 1, n_fields
n_owned = desc_grid%descs(1,i_field)%get_local_rows()
n_local = desc_grid%descs(1,i_field)%get_local_cols()
do i_loc = n_owned + 1, n_local
call desc_grid%descs(1,i_field)%l2g(i_loc, global_idx, info)
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='l2g halo'); return
end if
halo_count = halo_count + 1
halo_global(halo_count) = field_offset(i_field) + global_idx
end do
end do
call psb_cdins(halo_count, halo_global, desc_global, info)
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins'); return
end if
end if
! 5. assemble: build the global halo communication schedule (union halo)
call psb_cdasb(desc_global, info)
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb'); return
end if
end subroutine psb_cd_nest_compose
end module psb_cd_nest_tools_mod
base/modules/tools/psb_d_nest_builder_mod.F90
+368
View File
@@ -0,0 +1,368 @@
!
! 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_d_nest_builder_mod.F90
!
! Module: psb_d_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_d_nest_matrix, with the usual PSBLAS init/ins/asb pattern:
!
! type(psb_d_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_d_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_d_mat_mod, only : psb_dspmat_type
use psb_cd_tools_mod, only : psb_cdall, psb_cdins, psb_cdasb
use psb_desc_nest_mod, only : psb_desc_nest_type
use psb_d_nest_mat_mod, only : psb_d_nest_sparse_mat
use psb_d_nest_base_mat_mod, only : psb_d_nest_base_mat, psb_d_nest_base_setup
use psb_cd_nest_tools_mod, only : psb_cd_nest_compose
use psb_d_nest_tools_mod, only : psb_d_nest_rect_block
implicit none
! growing triplet buffer for a single block
type :: psb_d_nest_block_buffer
integer(psb_ipk_) :: n_entries = 0
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
real(psb_dpk_), allocatable :: entry_vals(:)
end type psb_d_nest_block_buffer
type :: psb_d_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_d_nest_block_buffer), allocatable :: block_buffer(:,:) ! triplets per block (i,j)
! products (owned; the pointers in a_glob%a point in here)
type(psb_d_nest_sparse_mat) :: block_storage
type(psb_desc_nest_type) :: grid_desc
type(psb_dspmat_type) :: a_glob ! the matrix to hand to Krylov
type(psb_desc_type) :: desc_glob ! the global descriptor
contains
procedure, pass(op) :: init => psb_d_nest_op_init
procedure, pass(op) :: ins => psb_d_nest_op_ins
procedure, pass(op) :: asb => psb_d_nest_op_asb
procedure, pass(op) :: free => psb_d_nest_op_free
end type psb_d_nest_matrix
private
public :: psb_d_nest_matrix
contains
! init: create one descriptor per field (block distribution from the global sizes)
subroutine psb_d_nest_op_init(op, context, field_sizes, info)
class(psb_d_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_d_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_d_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_d_nest_op_ins(op, block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info)
class(psb_d_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_dpk_), intent(in) :: entry_vals(:)
integer(psb_ipk_), intent(out) :: info
character(len=24) :: name
info = psb_success_
name = 'psb_d_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_d_nest_op_ins
! asb: assemble the descriptors, build the blocks, compose the global
! descriptor, set up the operator and wrap it into a_glob
subroutine psb_d_nest_op_asb(op, info)
class(psb_d_nest_matrix), intent(inout), target :: op
integer(psb_ipk_), intent(out) :: info
type(psb_d_nest_base_mat) :: nest_operator
integer(psb_ipk_) :: n_fields, i_field, j_field
character(len=24) :: name
info = psb_success_
name = 'psb_d_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_d_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)
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_d_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_d_nest_op_asb
! free: release everything
subroutine psb_d_nest_op_free(op, info)
class(psb_d_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_d_nest_op_free
!-----------------------------------------------------------------
! private helpers: growing triplet buffer
!-----------------------------------------------------------------
subroutine block_buffer_append(buffer, n_entries, entry_rows, entry_cols, entry_vals, info)
type(psb_d_nest_block_buffer), intent(inout) :: buffer
integer(psb_ipk_), intent(in) :: n_entries
integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:)
real(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_dpk(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_dpk(array, required_size, info)
real(psb_dpk_), allocatable, intent(inout) :: array(:)
integer(psb_ipk_), intent(in) :: required_size
integer(psb_ipk_), intent(out) :: info
real(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_dpk
subroutine block_buffer_free(buffer)
type(psb_d_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_d_nest_builder_mod
base/modules/tools/psb_d_nest_tools_mod.F90
+137 -214
View File
@@ -29,6 +29,9 @@
! POSSIBILITY OF SUCH DAMAGE.
!
!
! Module: psb_d_nest_tools_mod
! Author: Simone Staccone (Stack-1)
!
! Nested-specific assembly wrappers for PSBLAS3 — double precision matrix and vector routines
!
@@ -41,13 +44,15 @@ module psb_d_nest_tools_mod
psb_geall, psb_geins, psb_geasb, psb_gefree
use psb_desc_nest_mod, only : psb_desc_nest_type
use psb_d_nest_mat_mod, only : psb_d_nest_sparse_mat
use psb_d_nest_vect_mod, only : psb_d_nest_vect_type
use psb_d_mat_mod, only : psb_dspmat_type
use psb_d_base_mat_mod, only : psb_d_coo_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_geall_nest, psb_geins_nest, psb_geasb_nest, psb_gefree_nest
psb_d_nest_rect_block
contains
@@ -62,7 +67,7 @@ contains
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nnz
integer(psb_ipk_) :: i, j, linfo
integer(psb_ipk_) :: i_block_row, j_block_col, local_info
character(len=20) :: name
info = psb_success_
@@ -80,30 +85,19 @@ contains
end if
end if
if (.not. allocated(a_nest%blk_present)) then
allocate(a_nest%blk_present(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
a_nest%blk_present = .false.
end if
do i = 1, a_nest%nrblocks
do j = 1, a_nest%ncblocks
linfo = psb_success_
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, j), desc_nest%descs(i, j), linfo, nnz=nnz)
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, j), desc_nest%descs(i, j), linfo)
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 (linfo /= psb_success_) then
info = linfo
if (local_info /= psb_success_) then
info = local_info
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall')
return
end if
a_nest%blk_present(i, j) = .true.
end do
end do
@@ -114,24 +108,24 @@ contains
! The block is lazy-allocated on first insertion if psb_spall_nest
! was not called first.
subroutine psb_spins_nest(blk_i, blk_j, nz, ia, ja, val, a_nest, desc_nest, info)
integer(psb_ipk_), intent(in) :: blk_i, blk_j, nz
integer(psb_lpk_), intent(in) :: ia(:), ja(:)
real(psb_dpk_), intent(in) :: val(:)
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_dpk_), intent(in) :: entry_vals(:)
type(psb_d_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_est
integer(psb_ipk_) :: nnz_estimate
character(len=20) :: name
info = psb_success_
name = 'psb_spins_nest'
if (nz == 0) return
if (n_entries == 0) return
if (blk_i < 1 .or. blk_i > a_nest%nrblocks .or. &
blk_j < 1 .or. blk_j > a_nest%ncblocks) then
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
@@ -144,29 +138,21 @@ contains
call psb_errpush(info, name)
return
end if
allocate(a_nest%blk_present(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
a_nest%blk_present = .false.
end if
if (.not. a_nest%blk_present(blk_i, blk_j)) then
! Estimate nnz: use nz + 50% buffer for future insertions
nnz_est = max(nz, 10) + nz / 2
call psb_spall(a_nest%mats(blk_i, blk_j), &
desc_nest%descs(blk_i, blk_j), info, nnz=nnz_est)
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
a_nest%blk_present(blk_i, blk_j) = .true.
end if
call psb_spins(nz, ia, ja, val, a_nest%mats(blk_i, blk_j), &
desc_nest%descs(blk_i, blk_j), info)
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')
@@ -181,32 +167,33 @@ contains
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dupl
integer(psb_ipk_) :: i, j, dupl_, linfo
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_ = psb_dupl_add_
if (present(dupl)) dupl_ = dupl
info = psb_success_
name = 'psb_spasb_nest'
dupl_mode = psb_dupl_add_
if (present(dupl)) dupl_mode = dupl
do i = 1, a_nest%nrblocks
do j = 1, a_nest%ncblocks
if (a_nest%blk_present(i, j)) then
linfo = psb_success_
if (dupl_ == psb_dupl_add_) then
call psb_spasb(a_nest%mats(i, j), desc_nest%descs(i, j), linfo, &
dupl=psb_dupl_add_)
else if (dupl_ == psb_dupl_ovwrt_) then
call psb_spasb(a_nest%mats(i, j), desc_nest%descs(i, j), linfo, &
dupl=psb_dupl_ovwrt_)
else if (dupl_ == psb_dupl_err_) then
call psb_spasb(a_nest%mats(i, j), desc_nest%descs(i, j), linfo, &
dupl=psb_dupl_err_)
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, j), desc_nest%descs(i, j), linfo)
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 (linfo /= psb_success_) then
info = linfo
if (local_info /= psb_success_) then
info = local_info
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spasb')
return
end if
@@ -217,44 +204,34 @@ contains
end subroutine psb_spasb_nest
! Calls psb_spfree on every present block, then deallocates the
! mats and blk_present arrays and resets nrblocks/ncblocks to 0.
! mats array and resets nrblocks/ncblocks to 0.
subroutine psb_spfree_nest(a_nest, desc_nest, info)
type(psb_d_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, j, linfo
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 = 1, a_nest%nrblocks
do j = 1, a_nest%ncblocks
if (allocated(a_nest%blk_present)) then
if (a_nest%blk_present(i, j)) then
linfo = psb_success_
call psb_spfree(a_nest%mats(i, j), desc_nest%descs(i, j), linfo)
if (linfo /= psb_success_ .and. info == psb_success_) then
info = linfo
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spfree')
end if
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=linfo)
if (linfo /= 0 .and. info == psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
end if
end if
if (allocated(a_nest%blk_present)) then
deallocate(a_nest%blk_present, stat=linfo)
if (linfo /= 0 .and. info == psb_success_) then
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
@@ -274,25 +251,25 @@ contains
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: clear
integer(psb_ipk_) :: i, j, linfo
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) .or. .not. allocated(a_nest%blk_present)) return
if (.not. allocated(a_nest%mats)) return
do i = 1, a_nest%nrblocks
do j = 1, a_nest%ncblocks
if (a_nest%blk_present(i, j)) then
linfo = psb_success_
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, j), desc_nest%descs(i, j), linfo, clear=clear)
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, j), desc_nest%descs(i, j), linfo)
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 (linfo /= psb_success_ .and. info == psb_success_) then
info = linfo
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
@@ -302,132 +279,78 @@ contains
end subroutine psb_sprn_nest
! Allocates one sub-vector per block-row, using descs(i, 1) as
! the row descriptor for block i. Must be called before psb_geins_nest.
subroutine psb_geall_nest(x_nest, desc_nest, info)
type(psb_d_nest_vect_type), intent(out) :: x_nest
type(psb_desc_nest_type), intent(in) :: desc_nest
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, linfo
character(len=20) :: name
! psb_d_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_d_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_d_nest_rect_block(blk, nz, ia_glob, ja_glob, val, desc_row, desc_col, info)
type(psb_dspmat_type), intent(out) :: blk
integer(psb_ipk_), intent(in) :: nz
integer(psb_lpk_), intent(in) :: ia_glob(:), ja_glob(:)
real(psb_dpk_), intent(in) :: val(:)
type(psb_desc_type), intent(in) :: desc_row, desc_col
integer(psb_ipk_), intent(out) :: info
type(psb_d_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_geall_nest'
name = 'psb_d_nest_rect_block'
x_nest%nblocks = desc_nest%nrblocks
allocate(x_nest%vects(x_nest%nblocks), stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
return
end if
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)
do i = 1, x_nest%nblocks
linfo = psb_success_
call psb_geall(x_nest%vects(i), desc_nest%descs(i, 1), linfo)
if (linfo /= psb_success_) then
info = linfo
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_geall')
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
end do
end subroutine psb_geall_nest
! Inserts m entries into block blk_i of the nested vector.
subroutine psb_geins_nest(blk_i, m, irw, val, x_nest, desc_nest, info, local)
integer(psb_ipk_), intent(in) :: blk_i, m
integer(psb_lpk_), intent(in) :: irw(:)
real(psb_dpk_), intent(in) :: val(:)
type(psb_d_nest_vect_type), intent(inout) :: x_nest
type(psb_desc_nest_type), intent(in) :: desc_nest
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: local
character(len=20) :: name
info = psb_success_
name = 'psb_geins_nest'
if (m == 0) return
if (blk_i < 1 .or. blk_i > x_nest%nblocks) then
info = psb_err_invalid_input_
call psb_errpush(info, name, a_err='invalid block index')
return
end if
if (present(local)) then
call psb_geins(m, irw, val, x_nest%vects(blk_i), desc_nest%descs(blk_i, 1), info, &
local=local)
else
call psb_geins(m, irw, val, x_nest%vects(blk_i), desc_nest%descs(blk_i, 1), info)
end if
if (info /= psb_success_) &
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_geins')
end subroutine psb_geins_nest
! Calls psb_geasb on every sub-vector.
! Must be called after psb_cdasb_nest and all psb_geins_nest calls.
subroutine psb_geasb_nest(x_nest, desc_nest, info)
type(psb_d_nest_vect_type), intent(inout) :: x_nest
type(psb_desc_nest_type), intent(in) :: desc_nest
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, linfo
character(len=20) :: name
info = psb_success_
name = 'psb_geasb_nest'
do i = 1, x_nest%nblocks
linfo = psb_success_
call psb_geasb(x_nest%vects(i), desc_nest%descs(i, 1), linfo)
if (linfo /= psb_success_ .and. info == psb_success_) then
info = linfo
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_geasb')
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
end subroutine psb_geasb_nest
! Calls psb_gefree on every sub-vector, then deallocates the
! vects array and resets nblocks to 0.
subroutine psb_gefree_nest(x_nest, desc_nest, info)
type(psb_d_nest_vect_type), intent(inout) :: x_nest
type(psb_desc_nest_type), intent(in) :: desc_nest
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, linfo
character(len=20) :: name
info = psb_success_
name = 'psb_gefree_nest'
if (allocated(x_nest%vects)) then
do i = 1, x_nest%nblocks
linfo = psb_success_
call psb_gefree(x_nest%vects(i), desc_nest%descs(i, 1), linfo)
if (linfo /= psb_success_ .and. info == psb_success_) then
info = linfo
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_gefree')
end if
end do
deallocate(x_nest%vects, stat=linfo)
if (linfo /= 0 .and. info == psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
end if
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
x_nest%nblocks = 0
end subroutine psb_gefree_nest
call blk%mv_from(coo_block)
call blk%cscnv(info, type='CSR')
if (info /= 0) then
call psb_errpush(psb_err_from_subroutine_, name, a_err='cscnv'); return
end if
end subroutine psb_d_nest_rect_block
end module psb_d_nest_tools_mod