fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-16 19:02:09 +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
test/nested/CMakeLists.txt
+48
View File
@@ -0,0 +1,48 @@
cmake_minimum_required(VERSION 3.10)
project(nested Fortran)
# Check for the installation path for psblas
if(NOT DEFINED PSBLAS_INSTALL_DIR)
message(FATAL_ERROR "Please specify the path to the psblas installation directory using -DPSBLAS_INSTALL_DIR=<path>")
endif()
# Set the include and library directories based on the provided path
set(INSTALLDIR "${PSBLAS_INSTALL_DIR}")
set(INCDIR "${INSTALLDIR}/include")
set(MODDIR "${INSTALLDIR}/modules")
set(LIBDIR "${INSTALLDIR}/lib")
# Find the psblas package
find_package(psblas REQUIRED PATHS ${INSTALLDIR})
# Include directories for the Fortran compiler
include_directories(${INCDIR} ${MODDIR})
# Define executable directory
set(EXEDIR "${CMAKE_CURRENT_SOURCE_DIR}/runs")
file(MAKE_DIRECTORY ${EXEDIR})
# Nested (block-structured / MATNEST) tests
set(SOURCES_D_NEST_GLOB_TEST psb_d_nest_glob_test.F90)
set(SOURCES_D_NEST_RECT_TEST psb_d_nest_rect_test.F90)
set(SOURCES_D_NEST_CG_TEST psb_d_nest_cg_test.F90)
set(SOURCES_D_NEST_BUILDER_TEST psb_d_nest_builder_test.F90)
add_executable(psb_d_nest_glob_test ${SOURCES_D_NEST_GLOB_TEST})
target_link_libraries(psb_d_nest_glob_test psblas::util psblas::linsolve psblas::prec psblas::base)
add_executable(psb_d_nest_rect_test ${SOURCES_D_NEST_RECT_TEST})
target_link_libraries(psb_d_nest_rect_test psblas::util psblas::linsolve psblas::prec psblas::base)
add_executable(psb_d_nest_cg_test ${SOURCES_D_NEST_CG_TEST})
target_link_libraries(psb_d_nest_cg_test psblas::util psblas::linsolve psblas::prec psblas::base)
add_executable(psb_d_nest_builder_test ${SOURCES_D_NEST_BUILDER_TEST})
target_link_libraries(psb_d_nest_builder_test psblas::util psblas::linsolve psblas::prec psblas::base)
# Set output directory for executables
foreach(target psb_d_nest_glob_test psb_d_nest_rect_test psb_d_nest_cg_test psb_d_nest_builder_test)
set_target_properties(${target} PROPERTIES
RUNTIME_OUTPUT_DIRECTORY ${EXEDIR}
)
endforeach()
test/nested/Makefile
+46
View File
@@ -0,0 +1,46 @@
INSTALLDIR=../..
INCDIR=$(INSTALLDIR)/include
MODDIR=$(INSTALLDIR)/modules/
include $(INCDIR)/Make.inc.psblas
#
# Libraries used
LIBDIR=$(INSTALLDIR)/lib
PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_linsolve -lpsb_prec -lpsb_base
LDLIBS= $(PSBLDLIBS)
#
# Compilers and such
#
CCOPT= -g
FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG).
EXEDIR=./runs
all: runsd psb_d_nest_glob_test psb_d_nest_rect_test psb_d_nest_cg_test psb_d_nest_builder_test
runsd:
(if test ! -d runs ; then mkdir runs; fi)
psb_d_nest_glob_test: psb_d_nest_glob_test.o
$(FLINK) psb_d_nest_glob_test.o -o psb_d_nest_glob_test $(PSBLAS_LIB) $(LDLIBS)
/bin/mv psb_d_nest_glob_test $(EXEDIR)
psb_d_nest_rect_test: psb_d_nest_rect_test.o
$(FLINK) psb_d_nest_rect_test.o -o psb_d_nest_rect_test $(PSBLAS_LIB) $(LDLIBS)
/bin/mv psb_d_nest_rect_test $(EXEDIR)
psb_d_nest_cg_test: psb_d_nest_cg_test.o
$(FLINK) psb_d_nest_cg_test.o -o psb_d_nest_cg_test $(PSBLAS_LIB) $(LDLIBS)
/bin/mv psb_d_nest_cg_test $(EXEDIR)
psb_d_nest_builder_test: psb_d_nest_builder_test.o
$(FLINK) psb_d_nest_builder_test.o -o psb_d_nest_builder_test $(PSBLAS_LIB) $(LDLIBS)
/bin/mv psb_d_nest_builder_test $(EXEDIR)
clean:
/bin/rm -f psb_d_nest_glob_test.o psb_d_nest_rect_test.o psb_d_nest_cg_test.o psb_d_nest_builder_test.o *$(.mod) \
$(EXEDIR)/psb_d_nest_glob_test $(EXEDIR)/psb_d_nest_rect_test $(EXEDIR)/psb_d_nest_cg_test $(EXEDIR)/psb_d_nest_builder_test
verycleanlib:
(cd ../..; make veryclean)
lib:
(cd ../../; make library)
test/nested/README.md
+133
View File
@@ -0,0 +1,133 @@
# Nested (block-structured / MATNEST) matrices in PSBLAS
Author: Simone Staccone (Stack-1)
This directory contains the tests for the **nested matrix** support added to PSBLAS: a block-structured distributed operator
```
[ A11 A12 ... ]
M = [ A21 A22 ... ]
[ ... ... ]
```
whose blocks are kept as separate sparse matrices (one per field) but which presents itself to Krylov solvers and preconditioners as a **single ordinary distributed matrix**. It is the PSBLAS analogue of PETSc's `MATNEST`.
The motivating case is the **saddle-point** system
```
M = [ A B^T ]
[ B 0 ]
```
(symmetric indefinite, with the (2,2) block absent), but the implementation supports any square multi-field block operator with possibly **rectangular**
sub-blocks.
## 1. Concepts
* **Field** — a contiguous index space (e.g. velocity `V` and pressure `Q` in a saddle-point problem). Each field has its own `psb_desc_type` distribution.
* **Block (i,j)** — the sub-matrix coupling field `i` (rows) with field `j` (columns). It may be rectangular (`|field i| /= |field j|`) and may be absent.
* **Global operator** — the blocks are concatenated into a single **square** operator `M` of size `sum(field_sizes)`, distributed over one **composed global descriptor** with a **union halo** (one halo exchange per matrix-vector product, covering all blocks of a given column field at once).
* **Rectangular blocks** — PSBLAS does not support rectangular *distributed* matrices, but it does support rectangular *local* CSR/COO matrices. The rectangular product therefore happens only in the **local** block `csmv`; the only object carrying a descriptor (and hence communication) is the global operator, which is always square.
The global operator (`a_glob`) and global descriptor (`desc_glob`) can be passed unchanged to `psb_spmm`, `psb_krylov`, and the standard preconditioners.
## 2. Recommended API: `psb_d_nest_matrix`
The easy way to build a nested matrix is the `psb_d_nest_matrix` type (module `psb_d_nest_builder_mod`, re-exported by the umbrella `psb_d_nest_mod`), which follows the usual PSBLAS `init` / `ins` / `asb` pattern and hides all the descriptor / halo / compose / setup boilerplate:
```fortran
use psb_d_nest_mod
type(psb_d_nest_matrix) :: nested_matrix
integer(psb_lpk_) :: n1, n2
! 1) declare the field structure: 2 fields of global size n1, n2
call nested_matrix%init(ctxt, [n1, n2], info)
! 2) insert the block values, owned rows only (PSBLAS convention).
! ins(block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info)
! rows are GLOBAL indices in field block_row, columns in field block_col.
call nested_matrix%ins(1, 1, nz_A, iaA, jaA, valA, info) ! A = block (1,1)
call nested_matrix%ins(1, 2, nz_Bt, iaBt, jaBt, valBt, info) ! B^T = block (1,2)
call nested_matrix%ins(2, 1, nz_B, iaB, jaB, valB, info) ! B = block (2,1)
! (the (2,2) block is simply not inserted)
! 3) assemble: builds nested_matrix%a_glob and nested_matrix%desc_glob
call nested_matrix%asb(info)
! 4) from here on it is 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, itmax=..., iter=..., err=...)
! 5) release
call nested_matrix%free(info)
```
Notes:
* To know which rows it owns in a field, a process can query the per-field descriptor exposed as `nested_matrix%field_desc(i)` (e.g. `nested_matrix%field_desc(1)%get_local_rows()` and `%l2g(...)`), exactly as it would with a plain `psb_cdall` descriptor.
* Off-diagonal blocks may be rectangular: the cross-field column indices are registered into the union halo automatically by `ins`.
* The CG solver requires an SPD operator; a genuine saddle-point operator is indefinite and needs MINRES/GMRES (plus, eventually, a block preconditioner).
* **Do not copy/move** a `psb_d_nest_matrix` after `asb`: the wrapped operator holds internal pointers into the object.
## 3. Low-level path (advanced)
`psb_d_nest_matrix` is built on three lower-level pieces, available directly for advanced use (see `psb_d_nest_cg_test.F90` for an end-to-end example):
* `psb_cd_nest_compose(grid_desc, desc_glob, info)` — compose the per-field descriptors into the single global descriptor with the union halo.
* `psb_d_nest_base_setup(nest_op, block_storage, grid_desc, desc_glob, info)` — set up the `psb_d_nest_base_mat` operator (implements the local `csmv`).
* `psb_d_nest_rect_block(blk, nz, ia, ja, val, desc_row, desc_col, info)` — build a single (possibly rectangular) local block from global triplets, with rows localized against `desc_row` and columns against `desc_col`.
A field-split interface (`psb_d_nest_get_block`, `psb_d_nest_get_field_desc`,
`psb_d_nest_restrict_field`, `psb_d_nest_prolong_field`,
`psb_d_nest_apply_block`) is exposed on `psb_d_nest_base_mat` as the hook for a future block (field-split / Schur) preconditioner.
## 4. Tests
| Test | What it checks |
|------------------------------|----------------|
| `psb_d_nest_glob_test` | Square 2×2 operator built with `psb_d_nest_matrix`; the nested `psb_spmm` is compared bit-for-bit against the same matrix assembled monolithically in CSR. |
| `psb_d_nest_rect_test` | Same, with fields of different size (`|V| = 2|Q|`) and genuinely **rectangular** off-diagonal blocks. |
| `psb_d_nest_cg_test` | Standard PSBLAS **CG** on an SPD, ill-conditioned operator (1D Laplacian reordered red-black), built on the **low-level path**; the solution is recovered to machine precision over hundreds of matvecs. |
| `psb_d_nest_builder_test` | Same CG solve as above but built through the `psb_d_nest_matrix` utility (high-level path). |
All tests run both serially and in parallel, and the result is invariant with respect to the number of MPI processes.
### Build and run
The PSBLAS library must be built/installed first (from the repository root):
```sh
make # or the CMake build
```
Then, from this directory:
```sh
make # builds the executables into ./runs
./runs/psb_d_nest_glob_test # serial
mpirun -np 4 ./runs/psb_d_nest_rect_test
mpirun -np 4 ./runs/psb_d_nest_cg_test
mpirun -np 4 ./runs/psb_d_nest_builder_test
```
Each test prints a single `[PASS]` / `[FAIL]` line (printed by rank 0).
## 5. Source files
Library (under `base/modules/`):
* `desc/psb_desc_nest_mod.f90` — `psb_desc_nest_type` (grid of per-field descriptors)
* `serial/psb_d_nest_mat_mod.f90` — `psb_d_nest_sparse_mat` (block storage)
* `serial/psb_d_nest_base_mat_mod.F90`— `psb_d_nest_base_mat` (the MATNEST operator + `csmv`)
* `tools/psb_cd_nest_tools_mod.F90` — descriptor tools (`psb_cd_nest_compose`, ...)
* `tools/psb_d_nest_tools_mod.F90` — block tools (`psb_d_nest_rect_block`, ...)
* `tools/psb_d_nest_builder_mod.F90` — `psb_d_nest_matrix` frontend (init/ins/asb)
* `psb_d_nest_mod.f90` — umbrella module (`use psb_d_nest_mod`)
test/nested/psb_d_nest_builder_test.F90
+207
View File
@@ -0,0 +1,207 @@
!
! 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_test.F90
!
! Program: psb_d_nest_builder_test
! Author: Simone Staccone (Stack-1)
!
! Same operator as the low-level CG test (1D Laplacian reordered red-black, SPD
! and ill-conditioned) but built with the psb_d_nest_matrix utility: the user
! declares nested_matrix, gives the field sizes, inserts the block values and
! calls asb. All the setup (per-field descriptors, union halo, compose, setup,
! wrap) is handled by the utility. Solved with CG and checked against the
! exact solution.
!
! M = [ 2I C ] C(r,r) = -1 , C(r,r-1) = -1 (the Laplacian edges)
! [ C^T 2I ]
!
! Run: ./psb_d_nest_builder_test ; mpirun -np 4 ./psb_d_nest_builder_test
!
program psb_d_nest_builder_test
use psb_base_mod
use psb_prec_mod
use psb_linsolve_mod
use psb_d_nest_mod ! umbrella: includes psb_d_nest_matrix (builder)
implicit none
type(psb_ctxt_type) :: context
integer(psb_ipk_) :: my_rank, num_procs, info, i_local_row, entry_idx
integer(psb_ipk_) :: field1_local_rows, field2_local_rows
integer(psb_lpk_) :: field1_global_row, field2_global_row, field_size
type(psb_d_nest_matrix) :: nested_matrix ! the only object needed
type(psb_dprec_type) :: preconditioner
type(psb_d_vect_type) :: x_solution, rhs, x_exact
real(psb_dpk_) :: insert_value(1)
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
real(psb_dpk_), allocatable :: entry_vals(:)
real(psb_dpk_) :: stop_tol, final_residual, norm_x_exact, solution_error
integer(psb_ipk_) :: max_iter, n_iter, stop_criterion
real(psb_dpk_), parameter :: solution_tol = 1.0e-6_psb_dpk_
call psb_init(context)
call psb_info(context, my_rank, num_procs)
field_size = 512 ! global size of each field (N = 2*field_size)
stop_tol = 1.0e-9_psb_dpk_
max_iter = 4000
stop_criterion = 2
!---------------------------------------------------------------
! 1) create the nested operator: 2 fields of global size field_size
!---------------------------------------------------------------
call nested_matrix%init(context, [field_size, field_size], info)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL init info=', info; goto 9999
end if
! rows owned by this process in each field
field1_local_rows = nested_matrix%field_desc(1)%get_local_rows()
field2_local_rows = nested_matrix%field_desc(2)%get_local_rows()
!---------------------------------------------------------------
! 2) insert the values, one block at a time (owned rows only)
!---------------------------------------------------------------
! block (1,1) = 2I
allocate(entry_rows(field1_local_rows), entry_cols(field1_local_rows), entry_vals(field1_local_rows))
do i_local_row = 1, field1_local_rows
call nested_matrix%field_desc(1)%l2g(i_local_row, field1_global_row, info)
entry_rows(i_local_row)=field1_global_row; entry_cols(i_local_row)=field1_global_row
entry_vals(i_local_row)=2.0_psb_dpk_
end do
call nested_matrix%ins(1, 1, field1_local_rows, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
! block (2,2) = 2I
allocate(entry_rows(field2_local_rows), entry_cols(field2_local_rows), entry_vals(field2_local_rows))
do i_local_row = 1, field2_local_rows
call nested_matrix%field_desc(2)%l2g(i_local_row, field2_global_row, info)
entry_rows(i_local_row)=field2_global_row; entry_cols(i_local_row)=field2_global_row
entry_vals(i_local_row)=2.0_psb_dpk_
end do
call nested_matrix%ins(2, 2, field2_local_rows, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
! block (1,2) = C : rows field1, cols field2 ; C(r,r)=-1, C(r,r-1)=-1
allocate(entry_rows(2*field1_local_rows), entry_cols(2*field1_local_rows), entry_vals(2*field1_local_rows))
entry_idx = 0
do i_local_row = 1, field1_local_rows
call nested_matrix%field_desc(1)%l2g(i_local_row, field1_global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field1_global_row
entry_cols(entry_idx) = field1_global_row
entry_vals(entry_idx) = -1.0_psb_dpk_
if (field1_global_row > 1) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field1_global_row
entry_cols(entry_idx) = field1_global_row - 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
end do
call nested_matrix%ins(1, 2, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
! block (2,1) = C^T : rows field2, cols field1 ; C^T(s,s)=-1, C^T(s,s+1)=-1
allocate(entry_rows(2*field2_local_rows), entry_cols(2*field2_local_rows), entry_vals(2*field2_local_rows))
entry_idx = 0
do i_local_row = 1, field2_local_rows
call nested_matrix%field_desc(2)%l2g(i_local_row, field2_global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field2_global_row
entry_cols(entry_idx) = field2_global_row
entry_vals(entry_idx) = -1.0_psb_dpk_
if (field2_global_row < field_size) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field2_global_row
entry_cols(entry_idx) = field2_global_row + 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
end do
call nested_matrix%ins(2, 1, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
!---------------------------------------------------------------
! 3) assemble: from here nested_matrix%a_glob / nested_matrix%desc_glob are ready for Krylov
!---------------------------------------------------------------
call nested_matrix%asb(info)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL asb info=', info; goto 9999
end if
!---------------------------------------------------------------
! 4) consistent RHS x_exact=1, rhs = M*x_exact, then solve with standard CG
!---------------------------------------------------------------
call psb_geall(x_exact, nested_matrix%desc_glob, info)
do i_local_row = 1, nested_matrix%desc_glob%get_local_rows()
call nested_matrix%desc_glob%l2g(i_local_row, field1_global_row, info)
insert_value(1) = 1.0_psb_dpk_
call psb_geins(1, [field1_global_row], insert_value, x_exact, nested_matrix%desc_glob, info)
end do
call psb_geasb(x_exact, nested_matrix%desc_glob, info)
call psb_geall(rhs, nested_matrix%desc_glob, info); call psb_geasb(rhs, nested_matrix%desc_glob, info)
call psb_spmm(done, nested_matrix%a_glob, x_exact, dzero, rhs, nested_matrix%desc_glob, info)
norm_x_exact = psb_genrm2(x_exact, nested_matrix%desc_glob, info)
call preconditioner%init(context, 'NONE', info)
call preconditioner%build(nested_matrix%a_glob, nested_matrix%desc_glob, info)
call psb_geall(x_solution, nested_matrix%desc_glob, info); call psb_geasb(x_solution, nested_matrix%desc_glob, info)
call psb_krylov('CG', nested_matrix%a_glob, preconditioner, rhs, x_solution, stop_tol, nested_matrix%desc_glob, info, &
& itmax=max_iter, iter=n_iter, err=final_residual, istop=stop_criterion)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL krylov info=', info; goto 9999
end if
call psb_geaxpby(-done, x_exact, done, x_solution, nested_matrix%desc_glob, info)
solution_error = psb_genrm2(x_solution, nested_matrix%desc_glob, info) / norm_x_exact
if (my_rank == 0) then
write(*,'(a,i0,a,i0)') ' np=', num_procs, ' N(global)=', 2*field_size
write(*,'(a,i0)') ' CG iterations = ', n_iter
write(*,'(a,es12.4)') ' CG relative residual = ', final_residual
write(*,'(a,es12.4)') ' ||x - x_exact||/||x_ex|| = ', solution_error
if ((n_iter < max_iter) .and. (solution_error <= solution_tol)) then
write(*,*) '[PASS] nested matrix built with the utility, solved with CG'
else
write(*,*) '[FAIL] tol ', solution_tol
end if
end if
call nested_matrix%free(info)
9999 continue
call psb_exit(context)
end program psb_d_nest_builder_test
test/nested/psb_d_nest_cg_test.F90
+301
View File
@@ -0,0 +1,301 @@
!
! 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_cg_test.F90
!
! Program: psb_d_nest_cg_test
! Author: Simone Staccone (Stack-1)
!
! Solves a linear system with the GLOBAL nested operator using the standard
! PSBLAS CG (psb_krylov('CG', ...)). This test builds the operator on the
! LOW-LEVEL path (per-field descriptors, blocks, compose, setup, wrap) to
! directly validate the machinery the psb_d_nest_matrix utility relies on; the
! same solve through the utility is in psb_d_nest_builder_test.
!
! CG needs a SYMMETRIC POSITIVE DEFINITE operator and, to stress the test
! (hundreds of matvecs), an ILL-CONDITIONED one. We use a real case: the 1D
! Laplacian tridiag(-1, 2, -1) on m = 2*field_size nodes, REORDERED red-black
! (odd nodes -> field 1, even nodes -> field 2). Under this reordering the
! Laplacian becomes exactly
!
! M = [ 2I C ] C(r,r) = -1 , C(r,r-1) = -1 (the Laplacian edges)
! [ C^T 2I ] C^T = exact transpose
!
! (odd nodes are not adjacent to each other -> diagonal blocks = 2I; every -1
! edge of the Laplacian becomes the coupling C). M is therefore the 1D
! Laplacian up to a permutation: SPD but with lambda_min ~ (pi/m)^2 => cond ~
! N^2 => CG performs O(N) iterations that GROW with N.
!
! Run: ./psb_d_nest_cg_test ; mpirun -np 4 ./psb_d_nest_cg_test
!
program psb_d_nest_cg_test
use psb_base_mod
use psb_util_mod
use psb_prec_mod
use psb_linsolve_mod
use psb_d_nest_mod
implicit none
type(psb_ctxt_type) :: context
integer(psb_ipk_) :: my_rank, num_procs, info, i_local_row, entry_idx, field_local_rows
integer(psb_lpk_) :: field1_global_row, field2_global_row, field_size
! per-field descriptors + blocks
type(psb_desc_type) :: field1_desc, field2_desc
type(psb_dspmat_type) :: diag_block1, coupling_12, coupling_21, diag_block2
! nested storage + grid descriptor + composed global path
type(psb_d_nest_sparse_mat) :: block_storage
type(psb_desc_nest_type) :: grid_desc
type(psb_desc_type) :: desc_global
type(psb_d_nest_base_mat) :: nest_operator
type(psb_dspmat_type) :: global_operator
! preconditioner + vectors
type(psb_dprec_type) :: preconditioner
type(psb_d_vect_type) :: x_solution, rhs, x_exact
real(psb_dpk_) :: insert_value(1)
! global triplets for the coupling blocks
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
real(psb_dpk_), allocatable :: entry_vals(:)
! solver parameters
real(psb_dpk_) :: diag_value, stop_tol, final_residual, norm_x_exact, solution_error
integer(psb_ipk_) :: max_iter, trace_level, n_iter, stop_criterion
real(psb_dpk_), parameter :: solution_tol = 1.0e-6_psb_dpk_
call psb_init(context)
call psb_info(context, my_rank, num_procs)
field_size = 512 ! global rows per field (global N = 2*field_size)
diag_value = 2.0_psb_dpk_ ! Laplacian diagonal (diagonal blocks = diag*I)
stop_tol = 1.0e-9_psb_dpk_
max_iter = 4000
trace_level = 0
stop_criterion = 2 ! stop on the relative residual
!---------------------------------------------------------------
! 1) per-field descriptors: block distribution of field_size global rows
! over num_procs processes (total size independent of num_procs)
!---------------------------------------------------------------
field_local_rows = int(field_size / int(num_procs, psb_lpk_), psb_ipk_)
if (int(my_rank, psb_lpk_) < mod(field_size, int(num_procs, psb_lpk_))) &
& field_local_rows = field_local_rows + 1
call psb_cdall(context, field1_desc, info, nl=field_local_rows)
call psb_cdall(context, field2_desc, info, nl=field_local_rows)
!---------------------------------------------------------------
! 2) diagonal blocks A = B = diag*I (odd/even nodes of the red-black
! reordered Laplacian are not adjacent to each other)
!---------------------------------------------------------------
call psb_spall(diag_block1, field1_desc, info, nnz=field1_desc%get_local_rows())
call psb_spall(diag_block2, field2_desc, info, nnz=field2_desc%get_local_rows())
do i_local_row = 1, field1_desc%get_local_rows()
call field1_desc%l2g(i_local_row, field1_global_row, info)
insert_value(1) = diag_value
call psb_spins(1,[field1_global_row],[field1_global_row],insert_value,diag_block1,field1_desc,info)
end do
do i_local_row = 1, field2_desc%get_local_rows()
call field2_desc%l2g(i_local_row, field2_global_row, info)
insert_value(1) = diag_value
call psb_spins(1,[field2_global_row],[field2_global_row],insert_value,diag_block2,field2_desc,info)
end do
!---------------------------------------------------------------
! 3) register, in the union halo, the cross-field columns of the coupling blocks
! C (row field1, col field2): columns {r, r-1} in field2 -> into field2_desc
! C^T (row field2, col field1): columns {s, s+1} in field1 -> into field1_desc
!---------------------------------------------------------------
do i_local_row = 1, field1_desc%get_local_rows()
call field1_desc%l2g(i_local_row, field1_global_row, info)
call psb_cdins(1, [field1_global_row], field2_desc, info)
if (field1_global_row > 1) call psb_cdins(1, [field1_global_row-1_psb_lpk_], field2_desc, info)
end do
do i_local_row = 1, field2_desc%get_local_rows()
call field2_desc%l2g(i_local_row, field2_global_row, info)
call psb_cdins(1, [field2_global_row], field1_desc, info)
if (field2_global_row < field_size) call psb_cdins(1, [field2_global_row+1_psb_lpk_], field1_desc, info)
end do
call psb_cdasb(field1_desc, info)
call psb_cdasb(field2_desc, info)
call psb_spasb(diag_block1, field1_desc, info, dupl=psb_dupl_add_)
call psb_spasb(diag_block2, field2_desc, info, dupl=psb_dupl_add_)
!---------------------------------------------------------------
! 4) coupling C (1,2): rows field1 (field1_desc), columns field2 (field2_desc)
! C(r,r) = -1 , C(r,r-1) = -1 (odd node 2r-1 -> even nodes 2r and 2r-2)
!---------------------------------------------------------------
allocate(entry_rows(2*field1_desc%get_local_rows()), entry_cols(2*field1_desc%get_local_rows()), &
& entry_vals(2*field1_desc%get_local_rows()))
entry_idx = 0
do i_local_row = 1, field1_desc%get_local_rows()
call field1_desc%l2g(i_local_row, field1_global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field1_global_row
entry_cols(entry_idx) = field1_global_row
entry_vals(entry_idx) = -1.0_psb_dpk_
if (field1_global_row > 1) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field1_global_row
entry_cols(entry_idx) = field1_global_row - 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
end do
call psb_d_nest_rect_block(coupling_12, entry_idx, entry_rows, entry_cols, entry_vals, field1_desc, field2_desc, info)
deallocate(entry_rows, entry_cols, entry_vals)
!---------------------------------------------------------------
! 5) coupling C^T (2,1) = exact transpose of C:
! rows field2 (field2_desc), columns field1 (field1_desc)
! C^T(s,s) = -1 , C^T(s,s+1) = -1 (even node 2s -> odd nodes 2s-1 and 2s+1)
!---------------------------------------------------------------
allocate(entry_rows(2*field2_desc%get_local_rows()), entry_cols(2*field2_desc%get_local_rows()), &
& entry_vals(2*field2_desc%get_local_rows()))
entry_idx = 0
do i_local_row = 1, field2_desc%get_local_rows()
call field2_desc%l2g(i_local_row, field2_global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field2_global_row
entry_cols(entry_idx) = field2_global_row
entry_vals(entry_idx) = -1.0_psb_dpk_
if (field2_global_row < field_size) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = field2_global_row
entry_cols(entry_idx) = field2_global_row + 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
end do
call psb_d_nest_rect_block(coupling_21, entry_idx, entry_rows, entry_cols, entry_vals, field2_desc, field1_desc, info)
deallocate(entry_rows, entry_cols, entry_vals)
!---------------------------------------------------------------
! 6) nested grid (all four blocks present)
!---------------------------------------------------------------
block_storage%nrblocks = 2
block_storage%ncblocks = 2
allocate(block_storage%mats(2,2))
call psb_move_alloc(diag_block1, block_storage%mats(1,1), info)
call psb_move_alloc(coupling_12, block_storage%mats(1,2), info)
call psb_move_alloc(coupling_21, block_storage%mats(2,1), info)
call psb_move_alloc(diag_block2, block_storage%mats(2,2), info)
grid_desc%nrblocks = 2
grid_desc%ncblocks = 2
allocate(grid_desc%descs(2,2))
call field1_desc%clone(grid_desc%descs(1,1), info)
call field2_desc%clone(grid_desc%descs(1,2), info)
call field1_desc%clone(grid_desc%descs(2,1), info)
call field2_desc%clone(grid_desc%descs(2,2), info)
!---------------------------------------------------------------
! 7) composed global operator (what CG will use as its matrix)
!---------------------------------------------------------------
call psb_cd_nest_compose(grid_desc, desc_global, info)
if (info /= psb_success_) then
if (my_rank == 0) write(*,*) 'FAIL: psb_cd_nest_compose info=', info
goto 9999
end if
call psb_d_nest_base_setup(nest_operator, block_storage, grid_desc, desc_global, info)
if (info /= psb_success_) then
if (my_rank == 0) write(*,*) 'FAIL: psb_d_nest_base_setup info=', info
goto 9999
end if
allocate(global_operator%a, source=nest_operator)
call global_operator%set_nrows(desc_global%get_local_rows())
call global_operator%set_ncols(desc_global%get_local_cols())
call global_operator%set_asb()
!---------------------------------------------------------------
! 8) consistent RHS: x_exact = 1, rhs = M * x_exact (via the nested operator)
!---------------------------------------------------------------
call psb_geall(x_exact, desc_global, info)
do i_local_row = 1, desc_global%get_local_rows()
call desc_global%l2g(i_local_row, field1_global_row, info)
insert_value(1) = 1.0_psb_dpk_
call psb_geins(1, [field1_global_row], insert_value, x_exact, desc_global, info)
end do
call psb_geasb(x_exact, desc_global, info)
call psb_geall(rhs, desc_global, info); call psb_geasb(rhs, desc_global, info)
call psb_spmm(done, global_operator, x_exact, dzero, rhs, desc_global, info)
if (info /= psb_success_) then
if (my_rank == 0) write(*,*) 'FAIL: psb_spmm (RHS) info=', info
goto 9999
end if
norm_x_exact = psb_genrm2(x_exact, desc_global, info)
!---------------------------------------------------------------
! 9) identity preconditioner (NONE): CG exercises only the operator
!---------------------------------------------------------------
call preconditioner%init(context, 'NONE', info)
call preconditioner%build(global_operator, desc_global, info)
if (info /= psb_success_) then
if (my_rank == 0) write(*,*) 'FAIL: preconditioner%build info=', info
goto 9999
end if
!---------------------------------------------------------------
! 10) solve with the standard PSBLAS CG
!---------------------------------------------------------------
call psb_geall(x_solution, desc_global, info); call psb_geasb(x_solution, desc_global, info)
call psb_krylov('CG', global_operator, preconditioner, rhs, x_solution, stop_tol, desc_global, info, &
& itmax=max_iter, iter=n_iter, err=final_residual, itrace=trace_level, istop=stop_criterion)
if (info /= psb_success_) then
if (my_rank == 0) write(*,*) 'FAIL: psb_krylov(CG) info=', info
goto 9999
end if
!---------------------------------------------------------------
! 11) solution error: || x_solution - x_exact || / || x_exact ||
!---------------------------------------------------------------
call psb_geaxpby(-done, x_exact, done, x_solution, desc_global, info) ! x_solution <- x_solution - x_exact
solution_error = psb_genrm2(x_solution, desc_global, info) / norm_x_exact
if (my_rank == 0) then
write(*,'(a,i0,a,i0)') ' np=', num_procs, ' N(global)=', 2*field_size
write(*,'(a,i0)') ' CG iterations = ', n_iter
write(*,'(a,es12.4)') ' CG relative residual = ', final_residual
write(*,'(a,es12.4)') ' ||x - x_exact||/||x_ex|| = ', solution_error
if ((n_iter < max_iter) .and. (solution_error <= solution_tol)) then
write(*,*) '[PASS] CG converges on the global nested operator'
else
write(*,*) '[FAIL] CG does not converge / wrong solution (tol ', solution_tol, ')'
end if
end if
9999 continue
call psb_exit(context)
end program psb_d_nest_cg_test
test/nested/psb_d_nest_glob_test.F90
+218
View File
@@ -0,0 +1,218 @@
!
! 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_glob_test.F90
!
! Program: psb_d_nest_glob_test
! Author: Simone Staccone (Stack-1)
!
! Validates the "global nested operator" path built through the
! psb_d_nest_matrix utility (init/ins/asb): the user only supplies the field
! sizes and the block values, and obtains nested_matrix%a_glob /
! nested_matrix%desc_glob ready for psb_spmm. The result is compared against
! the SAME matrix assembled monolithically in CSR on the same global
! descriptor (oracle).
!
! 2x2 operator (fields of size field_size):
! [ A B^T ] A = tridiag(-1, 2, -1) (block 1,1)
! [ B 0 ] B^T = 0.5 * I (block 1,2)
! B = 0.3 * I (block 2,1)
! (2,2) absent
!
! Run: ./psb_d_nest_glob_test (serial)
! mpirun -np 4 ./psb_d_nest_glob_test
!
program psb_d_nest_glob_test
use psb_base_mod
use psb_util_mod
use psb_d_nest_mod
implicit none
type(psb_ctxt_type) :: context
integer(psb_ipk_) :: my_rank, num_procs, info, i_local_row
integer(psb_ipk_) :: entry_idx, field1_local_rows, field2_local_rows
integer(psb_lpk_) :: global_row, global_col, field_size
type(psb_d_nest_matrix) :: nested_matrix ! the nested operator (init/ins/asb)
type(psb_dspmat_type) :: monolithic_ref ! monolithic CSR oracle
type(psb_d_vect_type) :: x_vec, y_nested, y_monolithic
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
real(psb_dpk_), allocatable :: entry_vals(:)
real(psb_dpk_) :: insert_value(1)
real(psb_dpk_) :: mismatch_norm
real(psb_dpk_), parameter :: tolerance = 1.0e-10_psb_dpk_
call psb_init(context)
call psb_info(context, my_rank, num_procs)
field_size = 32 ! global size of each field
!---------------------------------------------------------------
! 1) build the 2x2 nested operator through the utility
!---------------------------------------------------------------
call nested_matrix%init(context, [field_size, field_size], info)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL: nested_matrix%init info=', info; goto 9999
end if
field1_local_rows = nested_matrix%field_desc(1)%get_local_rows()
field2_local_rows = nested_matrix%field_desc(2)%get_local_rows()
!---------------------------------------------------------------
! 2) insert the block values (owned rows only)
!---------------------------------------------------------------
! A = tridiag(-1,2,-1) -> block (1,1)
allocate(entry_rows(3*field1_local_rows), entry_cols(3*field1_local_rows), &
& entry_vals(3*field1_local_rows))
entry_idx = 0
do i_local_row = 1, field1_local_rows
call nested_matrix%field_desc(1)%l2g(i_local_row, global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = global_row
entry_cols(entry_idx) = global_row
entry_vals(entry_idx) = 2.0_psb_dpk_
if (global_row > 1) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = global_row
entry_cols(entry_idx) = global_row - 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
if (global_row < field_size) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = global_row
entry_cols(entry_idx) = global_row + 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
end do
call nested_matrix%ins(1, 1, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
! B^T = 0.5 I -> block (1,2): rows in field 1, columns in field 2
allocate(entry_rows(field1_local_rows), entry_cols(field1_local_rows), entry_vals(field1_local_rows))
entry_idx = 0
do i_local_row = 1, field1_local_rows
call nested_matrix%field_desc(1)%l2g(i_local_row, global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = global_row
entry_cols(entry_idx) = global_row
entry_vals(entry_idx) = 0.5_psb_dpk_
end do
call nested_matrix%ins(1, 2, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
! B = 0.3 I -> block (2,1): rows in field 2, columns in field 1
allocate(entry_rows(field2_local_rows), entry_cols(field2_local_rows), entry_vals(field2_local_rows))
entry_idx = 0
do i_local_row = 1, field2_local_rows
call nested_matrix%field_desc(2)%l2g(i_local_row, global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = global_row
entry_cols(entry_idx) = global_row
entry_vals(entry_idx) = 0.3_psb_dpk_
end do
call nested_matrix%ins(2, 1, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
call nested_matrix%asb(info)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL: nested_matrix%asb info=', info; goto 9999
end if
!---------------------------------------------------------------
! 3) monolithic oracle on nested_matrix%desc_glob (global offsets:
! field 1 -> g ; field 2 -> field_size + g)
!---------------------------------------------------------------
call psb_spall(monolithic_ref, nested_matrix%desc_glob, info, &
& nnz=5*nested_matrix%desc_glob%get_local_rows())
do i_local_row = 1, field1_local_rows ! field-1 rows
call nested_matrix%field_desc(1)%l2g(i_local_row, global_row, info)
insert_value(1) = 2.0_psb_dpk_
call psb_spins(1,[global_row],[global_row],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
if (global_row > 1) then
insert_value(1)=-1.0_psb_dpk_
call psb_spins(1,[global_row],[global_row-1_psb_lpk_],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
end if
if (global_row < field_size) then
insert_value(1)=-1.0_psb_dpk_
call psb_spins(1,[global_row],[global_row+1_psb_lpk_],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
end if
global_col = field_size + global_row
insert_value(1) = 0.5_psb_dpk_ ! B^T
call psb_spins(1,[global_row],[global_col],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
end do
do i_local_row = 1, field2_local_rows ! field-2 rows
call nested_matrix%field_desc(2)%l2g(i_local_row, global_row, info)
global_col = global_row
insert_value(1) = 0.3_psb_dpk_ ! B
call psb_spins(1,[field_size+global_row],[global_col],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
end do
call psb_spasb(monolithic_ref, nested_matrix%desc_glob, info, dupl=psb_dupl_add_)
!---------------------------------------------------------------
! 4) compare the two matrix-vector products on a distinct-valued x (x[g] = g)
!---------------------------------------------------------------
call psb_geall(x_vec, nested_matrix%desc_glob, info)
do i_local_row = 1, nested_matrix%desc_glob%get_local_rows()
call nested_matrix%desc_glob%l2g(i_local_row, global_row, info)
insert_value(1) = real(global_row, psb_dpk_)
call psb_geins(1, [global_row], insert_value, x_vec, nested_matrix%desc_glob, info)
end do
call psb_geasb(x_vec, nested_matrix%desc_glob, info)
call psb_geall(y_nested, nested_matrix%desc_glob, info); call psb_geasb(y_nested, nested_matrix%desc_glob, info)
call psb_geall(y_monolithic, nested_matrix%desc_glob, info); call psb_geasb(y_monolithic, nested_matrix%desc_glob, info)
call psb_spmm(done, nested_matrix%a_glob, x_vec, dzero, y_nested, nested_matrix%desc_glob, info) ! via nested csmv
if (info /= psb_success_) then
if (my_rank == 0) write(*,*) 'FAIL: psb_spmm (nested) info=', info
goto 9999
end if
call psb_spmm(done, monolithic_ref, x_vec, dzero, y_monolithic, nested_matrix%desc_glob, info) ! CSR oracle
call psb_geaxpby(done, y_nested, -done, y_monolithic, nested_matrix%desc_glob, info)
mismatch_norm = psb_genrm2(y_monolithic, nested_matrix%desc_glob, info)
if (my_rank == 0) then
write(*,'(a,i0,a,i0)') ' np=', num_procs, ' N(field)=', field_size
write(*,'(a,es12.4)') ' ||nested - monolithic||_2 = ', mismatch_norm
if (mismatch_norm <= tolerance) then
write(*,*) '[PASS] nested global operator matches monolithic CSR'
else
write(*,*) '[FAIL] mismatch above tolerance ', tolerance
end if
end if
call nested_matrix%free(info)
9999 continue
call psb_exit(context)
end program psb_d_nest_glob_test
test/nested/psb_d_nest_rect_test.F90
+217
View File
@@ -0,0 +1,217 @@
!
! 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_rect_test.F90
!
! Program: psb_d_nest_rect_test
! Author: Simone Staccone (Stack-1)
!
! Like psb_d_nest_glob_test but with fields of DIFFERENT size (|V| = 2|Q|) and
! GENUINELY RECTANGULAR off-diagonal blocks. The operator is built with the
! psb_d_nest_matrix utility (init/ins/asb): the user only inserts the values,
! while the cross-field halo registration and the construction of the
! rectangular local blocks are handled internally. Compared against the
! monolithic CSR oracle.
!
! [ A B^T ] A : V x V tridiag(-1,2,-1)
! [ B 0 ] B^T : V x Q rectangular (row r -> col mod(r-1,nQ)+1, val 0.5)
! B : Q x V rectangular (row q -> cols q and q+nQ, val 0.3)
! (2,2) absent
!
! Run: ./psb_d_nest_rect_test ; mpirun -np 4 ./psb_d_nest_rect_test
!
program psb_d_nest_rect_test
use psb_base_mod
use psb_util_mod
use psb_d_nest_mod
implicit none
type(psb_ctxt_type) :: context
integer(psb_ipk_) :: my_rank, num_procs, info, i_local_row
integer(psb_ipk_) :: entry_idx, v_local_rows, q_local_rows
integer(psb_lpk_) :: v_global_row, q_global_row, q_col, v_size, q_size
type(psb_d_nest_matrix) :: nested_matrix
type(psb_dspmat_type) :: monolithic_ref
type(psb_d_vect_type) :: x_vec, y_nested, y_monolithic
real(psb_dpk_) :: insert_value(1)
integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:)
real(psb_dpk_), allocatable :: entry_vals(:)
real(psb_dpk_) :: mismatch_norm
real(psb_dpk_), parameter :: tolerance = 1.0e-10_psb_dpk_
call psb_init(context)
call psb_info(context, my_rank, num_procs)
q_size = 16 ! global size of field Q
v_size = 2*q_size ! global size of field V (|V| = 2|Q|)
!---------------------------------------------------------------
! 1) build the 2x2 nested operator (fields V, Q)
!---------------------------------------------------------------
call nested_matrix%init(context, [v_size, q_size], info)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL: nested_matrix%init info=', info; goto 9999
end if
v_local_rows = nested_matrix%field_desc(1)%get_local_rows()
q_local_rows = nested_matrix%field_desc(2)%get_local_rows()
!---------------------------------------------------------------
! 2) insert the blocks (owned rows only)
!---------------------------------------------------------------
! A = tridiag(-1,2,-1) -> block (1,1), V x V
allocate(entry_rows(3*v_local_rows), entry_cols(3*v_local_rows), entry_vals(3*v_local_rows))
entry_idx = 0
do i_local_row = 1, v_local_rows
call nested_matrix%field_desc(1)%l2g(i_local_row, v_global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = v_global_row
entry_cols(entry_idx) = v_global_row
entry_vals(entry_idx) = 2.0_psb_dpk_
if (v_global_row > 1) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = v_global_row
entry_cols(entry_idx) = v_global_row - 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
if (v_global_row < v_size) then
entry_idx = entry_idx + 1
entry_rows(entry_idx) = v_global_row
entry_cols(entry_idx) = v_global_row + 1_psb_lpk_
entry_vals(entry_idx) = -1.0_psb_dpk_
end if
end do
call nested_matrix%ins(1, 1, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
! B^T rectangular -> block (1,2), V x Q : row r -> col mod(r-1,nQ)+1, val 0.5
allocate(entry_rows(v_local_rows), entry_cols(v_local_rows), entry_vals(v_local_rows))
entry_idx = 0
do i_local_row = 1, v_local_rows
call nested_matrix%field_desc(1)%l2g(i_local_row, v_global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = v_global_row
entry_cols(entry_idx) = mod(v_global_row-1_psb_lpk_, q_size)+1
entry_vals(entry_idx) = 0.5_psb_dpk_
end do
call nested_matrix%ins(1, 2, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
! B rectangular -> block (2,1), Q x V : row q -> cols q and q+nQ, val 0.3
allocate(entry_rows(2*q_local_rows), entry_cols(2*q_local_rows), entry_vals(2*q_local_rows))
entry_idx = 0
do i_local_row = 1, q_local_rows
call nested_matrix%field_desc(2)%l2g(i_local_row, q_global_row, info)
entry_idx = entry_idx + 1
entry_rows(entry_idx) = q_global_row
entry_cols(entry_idx) = q_global_row
entry_vals(entry_idx) = 0.3_psb_dpk_
entry_idx = entry_idx + 1
entry_rows(entry_idx) = q_global_row
entry_cols(entry_idx) = q_global_row + q_size
entry_vals(entry_idx) = 0.3_psb_dpk_
end do
call nested_matrix%ins(2, 1, entry_idx, entry_rows, entry_cols, entry_vals, info)
deallocate(entry_rows, entry_cols, entry_vals)
call nested_matrix%asb(info)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL: nested_matrix%asb info=', info; goto 9999
end if
!---------------------------------------------------------------
! 3) monolithic oracle on nested_matrix%desc_glob (global offsets: V -> g, Q -> v_size + g)
!---------------------------------------------------------------
call psb_spall(monolithic_ref, nested_matrix%desc_glob, info, &
& nnz=6*nested_matrix%desc_glob%get_local_rows())
do i_local_row = 1, v_local_rows ! V rows
call nested_matrix%field_desc(1)%l2g(i_local_row, v_global_row, info)
insert_value(1)=2.0_psb_dpk_
call psb_spins(1,[v_global_row],[v_global_row],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
if (v_global_row>1) then
insert_value(1)=-1.0_psb_dpk_
call psb_spins(1,[v_global_row],[v_global_row-1_psb_lpk_],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
end if
if (v_global_row<v_size) then
insert_value(1)=-1.0_psb_dpk_
call psb_spins(1,[v_global_row],[v_global_row+1_psb_lpk_],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
end if
q_col = v_size + (mod(v_global_row-1_psb_lpk_, q_size) + 1)
insert_value(1)=0.5_psb_dpk_ ! B^T
call psb_spins(1,[v_global_row],[q_col],insert_value,monolithic_ref,nested_matrix%desc_glob,info)
end do
do i_local_row = 1, q_local_rows ! Q rows
call nested_matrix%field_desc(2)%l2g(i_local_row, q_global_row, info)
insert_value(1)=0.3_psb_dpk_
call psb_spins(1,[v_size+q_global_row],[q_global_row], insert_value,monolithic_ref,nested_matrix%desc_glob,info) ! col q
call psb_spins(1,[v_size+q_global_row],[q_global_row+q_size],insert_value,monolithic_ref,nested_matrix%desc_glob,info) ! col q+nQ
end do
call psb_spasb(monolithic_ref, nested_matrix%desc_glob, info, dupl=psb_dupl_add_)
!---------------------------------------------------------------
! 4) compare the two matrix-vector products on x[g] = g
!---------------------------------------------------------------
call psb_geall(x_vec, nested_matrix%desc_glob, info)
do i_local_row = 1, nested_matrix%desc_glob%get_local_rows()
call nested_matrix%desc_glob%l2g(i_local_row, v_global_row, info)
insert_value(1) = real(v_global_row, psb_dpk_)
call psb_geins(1, [v_global_row], insert_value, x_vec, nested_matrix%desc_glob, info)
end do
call psb_geasb(x_vec, nested_matrix%desc_glob, info)
call psb_geall(y_nested, nested_matrix%desc_glob, info); call psb_geasb(y_nested, nested_matrix%desc_glob, info)
call psb_geall(y_monolithic, nested_matrix%desc_glob, info); call psb_geasb(y_monolithic, nested_matrix%desc_glob, info)
call psb_spmm(done, nested_matrix%a_glob, x_vec, dzero, y_nested, nested_matrix%desc_glob, info)
if (info /= psb_success_) then
if (my_rank==0) write(*,*) 'FAIL spmm nested info=', info; goto 9999
end if
call psb_spmm(done, monolithic_ref, x_vec, dzero, y_monolithic, nested_matrix%desc_glob, info)
call psb_geaxpby(done, y_nested, -done, y_monolithic, nested_matrix%desc_glob, info)
mismatch_norm = psb_genrm2(y_monolithic, nested_matrix%desc_glob, info)
if (my_rank == 0) then
write(*,'(a,i0,a,i0,a,i0)') ' np=', num_procs, ' |V|=', v_size, ' |Q|=', q_size
write(*,'(a,es12.4)') ' ||nested - monolithic||_2 = ', mismatch_norm
if (mismatch_norm <= tolerance) then
write(*,*) '[PASS] rectangular nested operator matches monolithic CSR'
else
write(*,*) '[FAIL] mismatch above tolerance ', tolerance
end if
end if
call nested_matrix%free(info)
9999 continue
call psb_exit(context)
end program psb_d_nest_rect_test