You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
585 lines
22 KiB
Fortran
585 lines
22 KiB
Fortran
!
|
|
! 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_cd_nest_tools_mod
|
|
! Author: Simone Staccone (Stack-1)
|
|
!
|
|
! Nested-specific assembly wrappers for PSBLAS3 — descriptor routines
|
|
!
|
|
|
|
module psb_cd_nest_tools_mod
|
|
use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_success_, psb_err_alloc_dealloc_, &
|
|
psb_err_invalid_input_, psb_err_no_optional_arg_, psb_err_from_subroutine_, &
|
|
psb_ctxt_type
|
|
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_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)
|
|
interface psb_cdins_nest
|
|
#if defined(PSB_IPK4) && defined(PSB_LPK8)
|
|
module procedure psb_cdins_nest_c
|
|
module procedure psb_cdins_nest_rc_sub
|
|
#endif
|
|
module procedure psb_lcdins_nest_c
|
|
module procedure psb_lcdins_nest_rc
|
|
end interface
|
|
|
|
! Row+column form: (blk_i, blk_j, nz, ia, ja, desc_nest, info)
|
|
interface psb_cdins_nest_rc
|
|
#if defined(PSB_IPK4) && defined(PSB_LPK8)
|
|
module procedure psb_cdins_nest_rc_sub
|
|
#endif
|
|
module procedure psb_lcdins_nest_rc
|
|
end interface
|
|
|
|
contains
|
|
|
|
! Allocates the nested descriptor structure and creates block
|
|
! descriptors. The first block of each row uses psb_cdall with
|
|
! the given local row count; subsequent blocks in the same row
|
|
! are clones of the first block (same row distribution).
|
|
!
|
|
! Arguments:
|
|
! ctxt - PSBLAS context
|
|
! desc_nest - nested descriptor (output)
|
|
! info - error code (output)
|
|
! nrblocks - number of block rows (optional, default 2)
|
|
! ncblocks - number of block columns (optional, default 2)
|
|
! nl - local row count per process (required for first blocks)
|
|
|
|
subroutine psb_cdall_nest(ctxt, desc_nest, info, nrblocks, ncblocks, nl)
|
|
type(psb_ctxt_type), intent(in) :: ctxt
|
|
type(psb_desc_nest_type), intent(out) :: desc_nest
|
|
integer(psb_ipk_), intent(out) :: info
|
|
integer(psb_ipk_), intent(in), optional :: nrblocks, ncblocks, 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
|
|
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
|
|
local_rows = nl
|
|
|
|
! Allocate nested descriptor structure
|
|
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)
|
|
return
|
|
end if
|
|
|
|
! Build descriptors: each block gets its own independent psb_cdall.
|
|
! Cloning a build-state descriptor shares its base_desc pointer; when
|
|
! 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_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
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
end subroutine psb_cdall_nest
|
|
|
|
|
|
#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(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
|
|
|
|
character(len=20) :: name
|
|
|
|
info = psb_success_
|
|
name = 'psb_cdins_nest'
|
|
|
|
if (n_entries == 0) return
|
|
|
|
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(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')
|
|
|
|
end subroutine psb_cdins_nest_rc_sub
|
|
|
|
|
|
! psb_cdins_nest_c: col-only form, ipk_ nz — only when ipk_ /= lpk_
|
|
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_block_row, local_info
|
|
character(len=20) :: name
|
|
|
|
info = psb_success_
|
|
name = 'psb_cdins_nest'
|
|
|
|
if (n_entries == 0) return
|
|
|
|
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_block_row = 1, desc_nest%nrblocks
|
|
local_info = psb_success_
|
|
if (present(mask)) then
|
|
if (present(lidx)) then
|
|
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(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(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, lidx=lidx)
|
|
else
|
|
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info)
|
|
end if
|
|
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_cdins')
|
|
end if
|
|
end do
|
|
|
|
end subroutine psb_cdins_nest_c
|
|
#endif
|
|
|
|
|
|
! psb_lcdins_nest_rc: row+col form, lpk_ nz
|
|
!
|
|
! 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(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
|
|
|
|
character(len=20) :: name
|
|
|
|
info = psb_success_
|
|
name = 'psb_cdins_nest'
|
|
|
|
if (n_entries == 0) return
|
|
|
|
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(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')
|
|
|
|
end subroutine psb_lcdins_nest_rc
|
|
|
|
|
|
! psb_lcdins_nest_c: col-only form, lpk_ nz
|
|
!
|
|
! 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(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_block_row, local_info
|
|
character(len=20) :: name
|
|
|
|
info = psb_success_
|
|
name = 'psb_cdins_nest'
|
|
|
|
if (n_entries == 0) return
|
|
|
|
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_block_row = 1, desc_nest%nrblocks
|
|
local_info = psb_success_
|
|
if (present(mask)) then
|
|
if (present(lidx)) then
|
|
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(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(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info, lidx=lidx)
|
|
else
|
|
call psb_cdins(n_entries, entry_cols, desc_nest%descs(i_block_row, block_col), local_info)
|
|
end if
|
|
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_cdins')
|
|
end if
|
|
end do
|
|
|
|
end subroutine psb_lcdins_nest_c
|
|
|
|
|
|
! psb_cdasb_nest: Finalize all nested descriptors
|
|
!
|
|
! Calls psb_cdasb on all block descriptors in the nested structure.
|
|
! This must be called after all psb_cdins_nest calls and
|
|
! before psb_spasb_nest.
|
|
!
|
|
! Arguments:
|
|
! desc_nest - nested descriptor (input/output)
|
|
! info - error code (output)
|
|
|
|
subroutine psb_cdasb_nest(desc_nest, info)
|
|
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
integer(psb_ipk_) :: i_block_row, j_block_col
|
|
character(len=20) :: name
|
|
|
|
info = psb_success_
|
|
name = 'psb_cdasb_nest'
|
|
|
|
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
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
end subroutine psb_cdasb_nest
|
|
|
|
|
|
! psb_cdfree_nest: Free all nested descriptors
|
|
!
|
|
! Calls psb_cdfree on every block descriptor in the nested
|
|
! structure, then deallocates the descriptor array and resets
|
|
! nrblocks/ncblocks to 0. Mirrors what psb_cdfree does for a
|
|
! single psb_desc_type.
|
|
!
|
|
! Arguments:
|
|
! desc_nest - nested descriptor (input/output)
|
|
! info - error code (output)
|
|
!
|
|
subroutine psb_cdfree_nest(desc_nest, info)
|
|
type(psb_desc_nest_type), intent(inout) :: desc_nest
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
character(len=20) :: name
|
|
|
|
info = psb_success_
|
|
name = 'psb_cdfree_nest'
|
|
|
|
call desc_nest%free(info)
|
|
if (info /= psb_success_) &
|
|
call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_desc_nest_free')
|
|
|
|
end subroutine psb_cdfree_nest
|
|
|
|
|
|
! psb_cdcpy_nest: Deep copy (clone) a nested descriptor
|
|
!
|
|
! Allocates desc_out and clones each block descriptor from desc_in
|
|
! using psb_cdcpy, preserving the full row/column block structure.
|
|
!
|
|
! Arguments:
|
|
! desc_in - source nested descriptor (inout — clone may need to read internal state)
|
|
! desc_out - destination nested descriptor (output)
|
|
! info - error code (output)
|
|
|
|
subroutine psb_cdcpy_nest(desc_in, desc_out, info)
|
|
type(psb_desc_nest_type), intent(inout) :: desc_in
|
|
type(psb_desc_nest_type), intent(out) :: desc_out
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
integer(psb_ipk_) :: i_block_row, j_block_col
|
|
character(len=20) :: name
|
|
|
|
info = psb_success_
|
|
name = 'psb_cdcpy_nest'
|
|
|
|
desc_out%nrblocks = desc_in%nrblocks
|
|
desc_out%ncblocks = desc_in%ncblocks
|
|
allocate(desc_out%descs(desc_in%nrblocks, desc_in%ncblocks), stat=info)
|
|
if (info /= 0) then
|
|
info = psb_err_alloc_dealloc_
|
|
call psb_errpush(info, name)
|
|
return
|
|
end if
|
|
|
|
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
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
end subroutine psb_cdcpy_nest
|
|
|
|
|
|
! psb_cdprt_nest: Print all block descriptors (debugging)
|
|
!
|
|
! Loops over all (i,j) block descriptors in the nested structure
|
|
! and calls psb_cdprt on each, prefixing the output with the block
|
|
! index. All optional arguments are forwarded unchanged.
|
|
!
|
|
! Arguments:
|
|
! iout - output unit
|
|
! desc_nest - nested descriptor (input)
|
|
! glob - passed to psb_cdprt (optional)
|
|
! short - passed to psb_cdprt (optional)
|
|
! verbosity - passed to psb_cdprt (optional)
|
|
|
|
subroutine psb_cdprt_nest(iout, desc_nest, glob, short, verbosity)
|
|
integer(psb_ipk_), intent(in) :: iout
|
|
type(psb_desc_nest_type), intent(in) :: desc_nest
|
|
logical, intent(in), optional :: glob, short
|
|
integer(psb_ipk_), intent(in), optional :: verbosity
|
|
|
|
integer(psb_ipk_) :: i_block_row, j_block_col
|
|
|
|
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_block_row,j_block_col), glob=glob, short=short, verbosity=verbosity)
|
|
else
|
|
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_block_row,j_block_col), glob=glob, verbosity=verbosity)
|
|
else
|
|
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_block_row,j_block_col), short=short, verbosity=verbosity)
|
|
else
|
|
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_block_row,j_block_col), verbosity=verbosity)
|
|
else
|
|
call psb_cdprt(iout, desc_nest%descs(i_block_row,j_block_col))
|
|
end if
|
|
end if
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
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
|