mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-24 14:51:49 +00:00
[ADD] Nested (MATNEST-style) block matrix support and tests
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
@@ -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()
|
||||
@@ -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)
|
||||
@@ -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`)
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -34,8 +34,6 @@ set(SOURCES_S_PDE3D psb_s_pde3d.F90)
|
||||
set(SOURCES_D_PDE2D psb_d_pde2d.F90)
|
||||
set(SOURCES_S_PDE2D psb_s_pde2d.F90)
|
||||
|
||||
set(SOURCES_D_PDE_NEST_PSBLAS psb_d_pde_nest_psblas.F90)
|
||||
set(SOURCES_D_PDE_NEST_KRYLOV psb_d_pde_nest_krylov.F90)
|
||||
|
||||
# Create executables
|
||||
add_executable(psb_d_pde3d ${SOURCES_D_PDE3D})
|
||||
@@ -50,14 +48,8 @@ target_link_libraries(psb_d_pde2d psblas::util psblas::linsolve psblas::prec psb
|
||||
add_executable(psb_s_pde2d ${SOURCES_S_PDE2D})
|
||||
target_link_libraries(psb_s_pde2d psblas::util psblas::linsolve psblas::prec psblas::base)
|
||||
|
||||
add_executable(psb_d_pde_nest_psblas ${SOURCES_D_PDE_NEST_PSBLAS})
|
||||
target_link_libraries(psb_d_pde_nest_psblas psblas::util psblas::linsolve psblas::prec psblas::base)
|
||||
|
||||
add_executable(psb_d_pde_nest_krylov ${SOURCES_D_PDE_NEST_KRYLOV})
|
||||
target_link_libraries(psb_d_pde_nest_krylov psblas::util psblas::linsolve psblas::prec psblas::base)
|
||||
|
||||
# Set output directory for executables
|
||||
foreach(target psb_d_pde3d psb_s_pde3d psb_d_pde2d psb_s_pde2d psb_dist1_pde2d psb_dist2_pde2d psb_dist3_pde2d psb_d_pde_nest_psblas psb_d_pde_nest_krylov)
|
||||
foreach(target psb_d_pde3d psb_s_pde3d psb_d_pde2d psb_s_pde2d psb_dist1_pde2d psb_dist2_pde2d psb_dist3_pde2d)
|
||||
set_target_properties(${target} PROPERTIES
|
||||
RUNTIME_OUTPUT_DIRECTORY ${EXEDIR}
|
||||
)
|
||||
|
||||
+3
-11
@@ -18,7 +18,7 @@ FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG).
|
||||
|
||||
EXEDIR=./runs
|
||||
|
||||
all: runsd psb_d_pde3d psb_s_pde3d psb_d_pde2d psb_s_pde2d psb_d_pde_nest_psblas psb_d_pde_nest_krylov
|
||||
all: runsd psb_d_pde3d psb_s_pde3d psb_d_pde2d psb_s_pde2d
|
||||
|
||||
runsd:
|
||||
(if test ! -d runs ; then mkdir runs; fi)
|
||||
@@ -40,17 +40,9 @@ psb_s_pde2d: psb_s_pde2d.o
|
||||
$(FLINK) psb_s_pde2d.o -o psb_s_pde2d $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv psb_s_pde2d $(EXEDIR)
|
||||
|
||||
psb_d_pde_nest_psblas: psb_d_pde_nest_psblas.o
|
||||
$(FLINK) psb_d_pde_nest_psblas.o -o psb_d_pde_nest_psblas $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv psb_d_pde_nest_psblas $(EXEDIR)
|
||||
|
||||
psb_d_pde_nest_krylov: psb_d_pde_nest_krylov.o
|
||||
$(FLINK) psb_d_pde_nest_krylov.o -o psb_d_pde_nest_krylov $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv psb_d_pde_nest_krylov $(EXEDIR)
|
||||
|
||||
clean:
|
||||
/bin/rm -f psb_d_pde3d.o psb_d_oacc_pde3d.o psb_s_pde3d.o psb_d_pde2d.o psb_s_pde2d.o psb_d_pde_nest_psblas.o psb_d_pde_nest_krylov.o *$(.mod) \
|
||||
$(EXEDIR)/psb_d_pde3d $(EXEDIR)/psb_s_pde3d $(EXEDIR)/psb_d_pde2d $(EXEDIR)/psb_s_pde2d $(EXEDIR)/psb_d_pde_nest_psblas $(EXEDIR)/psb_d_pde_nest_krylov
|
||||
/bin/rm -f psb_d_pde3d.o psb_d_oacc_pde3d.o psb_s_pde3d.o psb_d_pde2d.o psb_s_pde2d.o *$(.mod) \
|
||||
$(EXEDIR)/psb_d_pde3d $(EXEDIR)/psb_s_pde3d $(EXEDIR)/psb_d_pde2d $(EXEDIR)/psb_s_pde2d
|
||||
verycleanlib:
|
||||
(cd ../..; make veryclean)
|
||||
lib:
|
||||
|
||||
@@ -1,672 +0,0 @@
|
||||
!
|
||||
! Test code for all subroutines in psb_d_nest_psblas_mod.
|
||||
! Extends psb_d_pde_nest_first.F90: copies the same 2x2 saddle-point
|
||||
! setup (n=10 global DOFs per block), then exercises every operation
|
||||
! exported by psb_d_nest_psblas_mod.
|
||||
!
|
||||
! Tested subroutines
|
||||
! ------------------
|
||||
! T01 psb_d_nest_spmm y = alpha*A*x + beta*y (block SpMV)
|
||||
! T02 psb_d_nest_geaxpby y = alpha*x + beta*y
|
||||
! T03 psb_d_nest_genrm2 ||x||_2 (function)
|
||||
! T04 psb_d_nest_genrm2s ||x||_2 (subroutine)
|
||||
! T05 psb_d_nest_gedot dot(x, y)
|
||||
! T06 psb_d_nest_geamax ||x||_inf
|
||||
! T07 psb_d_nest_geasum ||x||_1
|
||||
! T08 psb_d_nest_gemin min(x)
|
||||
! T09 psb_d_nest_minquotient min(x/y)
|
||||
! T10 psb_d_nest_gemlt y = y * x (element-wise)
|
||||
! T11 psb_d_nest_gediv x = x / y (element-wise; result in x)
|
||||
! T12 psb_d_nest_geinv y = 1/x (result in y)
|
||||
! T13 psb_d_nest_geabs y = |x| (result in y)
|
||||
! T14 psb_d_nest_geaddconst z = x + b (result in z)
|
||||
! T15 psb_d_nest_gecmp z(i)=1 if |x(i)|>=c, 0 otherwise
|
||||
! T16 psb_d_nest_mask mask operation; t=.true. if all satisfied
|
||||
! T17 psb_d_nest_upd_xyz y=alpha*x+beta*y; z=gamma*y_new+delta*z
|
||||
!
|
||||
program psb_d_pde_nest_psblas
|
||||
use psb_base_mod
|
||||
use psb_desc_nest_mod
|
||||
use psb_d_nest_mod
|
||||
use psb_d_nest_tools_mod, only : psb_geall_nest, psb_geasb_nest, psb_gefree_nest, &
|
||||
& psb_geins_nest, psb_spall_nest, psb_spins_nest, &
|
||||
& psb_spasb_nest
|
||||
implicit none
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Parallel context
|
||||
!------------------------------------------------------------------
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np, info
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Problem size
|
||||
!------------------------------------------------------------------
|
||||
integer(psb_ipk_), parameter :: n = 100
|
||||
integer(psb_ipk_) :: nlr, iloc, i
|
||||
integer(psb_lpk_) :: iglob
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Per-block descriptors (identical layout as psb_d_pde_nest_first)
|
||||
!------------------------------------------------------------------
|
||||
type(psb_desc_type) :: desc1, desc2, desc3, desc4
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Nested descriptor and nested sparse matrix
|
||||
!------------------------------------------------------------------
|
||||
type(psb_desc_nest_type) :: descs
|
||||
type(psb_d_nest_sparse_mat) :: anest
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Individual sparse matrices (A11 = Laplacian, A12 = I, A21 = I)
|
||||
!------------------------------------------------------------------
|
||||
type(psb_dspmat_type) :: a11, a12, a21
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Work nested vectors (xnest, ynest, znest reused across tests)
|
||||
!------------------------------------------------------------------
|
||||
type(psb_d_nest_vect_type) :: xnest, ynest, znest
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Insert buffers
|
||||
!------------------------------------------------------------------
|
||||
integer(psb_lpk_) :: grow(1)
|
||||
real(psb_dpk_) :: gval(1)
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Scalar results and expected values
|
||||
!------------------------------------------------------------------
|
||||
real(psb_dpk_) :: res, res2, expected
|
||||
real(psb_dpk_), parameter :: tol = 1.0e-10_psb_dpk_
|
||||
logical :: t_mask
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Test pass/fail counter
|
||||
!------------------------------------------------------------------
|
||||
integer(psb_ipk_) :: npass, nfail
|
||||
|
||||
character(len=40) :: name = 'psb_d_pde_nest_psblas'
|
||||
|
||||
!==================================================================
|
||||
! Initialise MPI
|
||||
!==================================================================
|
||||
call psb_init(ctxt)
|
||||
call psb_info(ctxt, iam, np)
|
||||
call psb_set_errverbosity(itwo)
|
||||
|
||||
npass = 0
|
||||
nfail = 0
|
||||
|
||||
!==================================================================
|
||||
! Build per-block descriptors
|
||||
! Use exact block distribution so total rows = n exactly.
|
||||
! Ceiling division (n+np-1)/np gives nlr*np > n phantom rows
|
||||
! when np does not divide n evenly.
|
||||
!==================================================================
|
||||
nlr = n / np
|
||||
if (iam < mod(n, np)) nlr = nlr + 1_psb_ipk_
|
||||
nlr = max(1_psb_ipk_, nlr)
|
||||
call psb_cdall(ctxt, desc1, info, nl=nlr)
|
||||
call psb_cdall(ctxt, desc2, info, nl=nlr)
|
||||
call desc1%clone(desc3, info)
|
||||
|
||||
!==================================================================
|
||||
! A(1,1) = tridiagonal Laplacian
|
||||
!==================================================================
|
||||
call psb_spall(a11, desc1, info, nnz=3*desc1%get_local_rows())
|
||||
do iloc = 1, desc1%get_local_rows()
|
||||
call desc1%l2g(iloc, iglob, info)
|
||||
grow(1)=iglob; gval(1)=2.0_psb_dpk_
|
||||
call psb_spins(1,grow,grow,gval,a11,desc1,info)
|
||||
if (iglob>1) then
|
||||
grow(1)=iglob; gval(1)=-1.0_psb_dpk_
|
||||
call psb_spins(1,grow,[iglob-1_psb_lpk_],gval,a11,desc1,info)
|
||||
end if
|
||||
if (iglob<n) then
|
||||
grow(1)=iglob; gval(1)=-1.0_psb_dpk_
|
||||
call psb_spins(1,grow,[iglob+1_psb_lpk_],gval,a11,desc1,info)
|
||||
end if
|
||||
end do
|
||||
|
||||
!==================================================================
|
||||
! A(1,2) = Identity
|
||||
!==================================================================
|
||||
call psb_spall(a12, desc2, info, nnz=desc2%get_local_rows())
|
||||
do iloc = 1, desc2%get_local_rows()
|
||||
call desc2%l2g(iloc, iglob, info)
|
||||
grow(1)=iglob; gval(1)=1.0_psb_dpk_
|
||||
call psb_spins(1,grow,grow,gval,a12,desc2,info)
|
||||
end do
|
||||
|
||||
!==================================================================
|
||||
! A(2,1) = Identity
|
||||
!==================================================================
|
||||
call psb_spall(a21, desc3, info, nnz=desc3%get_local_rows())
|
||||
do iloc = 1, desc3%get_local_rows()
|
||||
call desc3%l2g(iloc, iglob, info)
|
||||
grow(1)=iglob; gval(1)=1.0_psb_dpk_
|
||||
call psb_spins(1,grow,grow,gval,a21,desc3,info)
|
||||
end do
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Finalise descriptors and assemble matrices
|
||||
!------------------------------------------------------------------
|
||||
call psb_cdasb(desc1, info)
|
||||
call psb_cdasb(desc2, info)
|
||||
call psb_cdasb(desc3, info)
|
||||
call desc2%clone(desc4, info)
|
||||
|
||||
call psb_spasb(a11, desc1, info, dupl=psb_dupl_add_)
|
||||
call psb_spasb(a12, desc2, info, dupl=psb_dupl_add_)
|
||||
call psb_spasb(a21, desc3, info, dupl=psb_dupl_add_)
|
||||
|
||||
!==================================================================
|
||||
! Assemble nested matrix
|
||||
!==================================================================
|
||||
anest%nrblocks = 2
|
||||
anest%ncblocks = 2
|
||||
allocate(anest%mats(2,2), anest%blk_present(2,2), stat=info)
|
||||
if (info /= 0) goto 9999
|
||||
anest%blk_present = .false.
|
||||
|
||||
call psb_move_alloc(a11, anest%mats(1,1), info)
|
||||
call psb_move_alloc(a12, anest%mats(1,2), info)
|
||||
call psb_move_alloc(a21, anest%mats(2,1), info)
|
||||
|
||||
anest%blk_present(1,1) = .true.
|
||||
anest%blk_present(1,2) = .true.
|
||||
anest%blk_present(2,1) = .true.
|
||||
|
||||
!==================================================================
|
||||
! Assemble nested descriptor
|
||||
!==================================================================
|
||||
descs%nrblocks = 2
|
||||
descs%ncblocks = 2
|
||||
allocate(descs%descs(2,2), stat=info)
|
||||
if (info /= 0) goto 9999
|
||||
|
||||
call desc1%clone(descs%descs(1,1), info)
|
||||
call desc2%clone(descs%descs(1,2), info)
|
||||
call desc3%clone(descs%descs(2,1), info)
|
||||
call desc4%clone(descs%descs(2,2), info)
|
||||
|
||||
!==================================================================
|
||||
! Allocate and assemble work nested vectors
|
||||
!==================================================================
|
||||
call psb_geall_nest(xnest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_geasb_nest(xnest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_geall_nest(ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_geasb_nest(ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_geall_nest(znest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_geasb_nest(znest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
!==================================================================
|
||||
! T01: psb_d_nest_spmm
|
||||
! x = all 1s; y = anest * x
|
||||
! Block 1 (Laplacian * ones): interior rows give 0, boundary rows
|
||||
! give 1 (first) or 1 (last), interior give 0.
|
||||
! Block 2 (A21 * ones) = ones.
|
||||
! Print both result blocks for visual inspection.
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T01: psb_d_nest_spmm (y = anest * x, x = all-1s)'
|
||||
|
||||
call set_nest_val(xnest, done)
|
||||
call ynest%zero()
|
||||
|
||||
call psb_d_nest_spmm(done, anest, xnest, dzero, ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
! call print_nest_vec(ynest, 'y = anest * [1,1]^T', iam, np, ctxt, descs)
|
||||
|
||||
! Expected values for y = anest * ones (ng=n ensures exactly n global rows):
|
||||
! Block 1: row 1 and row n give Lap=1, I=1 => y1=2 (2 boundary rows)
|
||||
! rows 2..n-1 give Lap=0, I=1 => y1=1 (n-2 interior rows)
|
||||
! Block 2: I*ones = 1 for all n rows
|
||||
! amax=2, gemin=1, geasum = (n+2) + n = 2n+2
|
||||
res = psb_d_nest_geamax(ynest, descs, info)
|
||||
call check('T01 spmm amax(y)=2', res, 2.0_psb_dpk_, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(ynest, descs, info)
|
||||
call check('T01 spmm gemin(y)=1', res, done, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_geasum(ynest, descs, info)
|
||||
expected = 2.0_psb_dpk_ * real(n, psb_dpk_) + 2.0_psb_dpk_
|
||||
call check('T01 spmm geasum(y)=2n+2', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T02: psb_d_nest_geaxpby
|
||||
! x = all 3s, y = all 2s
|
||||
! y = 2*x + (-1)*y => y = 2*3 - 2 = 4 (all 4s)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T02: psb_d_nest_geaxpby (y = 2*x - y, x=3 y=2 => 4)'
|
||||
|
||||
call set_nest_val(xnest, 3.0_psb_dpk_)
|
||||
call set_nest_val(ynest, 2.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_geaxpby(2.0_psb_dpk_, xnest, -done, ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = 4.0_psb_dpk_
|
||||
res = psb_d_nest_geamax(ynest, descs, info)
|
||||
call check('T02 geaxpby amax(y)=4', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(ynest, descs, info)
|
||||
call check('T02 geaxpby amin(y)=4', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T03: psb_d_nest_genrm2
|
||||
! x = all 1s => ||x||_2 = sqrt(2*n) = sqrt(20)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T03: psb_d_nest_genrm2 (x=1 => sqrt(2n))'
|
||||
|
||||
call set_nest_val(xnest, done)
|
||||
|
||||
res = psb_d_nest_genrm2(xnest, descs, info)
|
||||
expected = sqrt(2.0_psb_dpk_ * real(n, psb_dpk_))
|
||||
call check('T03 genrm2(ones)', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T04: psb_d_nest_genrm2s (subroutine form; result must equal T03)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T04: psb_d_nest_genrm2s (subroutine form of genrm2)'
|
||||
|
||||
call psb_d_nest_genrm2s(res2, xnest, descs, info)
|
||||
call check('T04 genrm2s == genrm2', res2, res, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T05: psb_d_nest_gedot
|
||||
! x = all 1s, y = all 2s => dot = 2 * 2*n = 40
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T05: psb_d_nest_gedot (x=1 y=2 => 2*2n=40)'
|
||||
|
||||
call set_nest_val(xnest, done)
|
||||
call set_nest_val(ynest, 2.0_psb_dpk_)
|
||||
|
||||
res = psb_d_nest_gedot(xnest, ynest, descs, info)
|
||||
expected = 2.0_psb_dpk_ * 2.0_psb_dpk_ * real(n, psb_dpk_)
|
||||
call check('T05 gedot', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T06: psb_d_nest_geamax
|
||||
! x = all 5s => ||x||_inf = 5
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T06: psb_d_nest_geamax (x=5 => 5)'
|
||||
|
||||
call set_nest_val(xnest, 5.0_psb_dpk_)
|
||||
|
||||
res = psb_d_nest_geamax(xnest, descs, info)
|
||||
expected = 5.0_psb_dpk_
|
||||
call check('T06 geamax', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T07: psb_d_nest_geasum
|
||||
! x = all 1s => ||x||_1 = 2*n = 20
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T07: psb_d_nest_geasum (x=1 => 2n=20)'
|
||||
|
||||
call set_nest_val(xnest, done)
|
||||
|
||||
res = psb_d_nest_geasum(xnest, descs, info)
|
||||
expected = 2.0_psb_dpk_ * real(n, psb_dpk_)
|
||||
call check('T07 geasum', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T08: psb_d_nest_gemin
|
||||
! x = all 7s => min = 7
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T08: psb_d_nest_gemin (x=7 => 7)'
|
||||
|
||||
call set_nest_val(xnest, 7.0_psb_dpk_)
|
||||
|
||||
res = psb_d_nest_gemin(xnest, descs, info)
|
||||
expected = 7.0_psb_dpk_
|
||||
call check('T08 gemin', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T09: psb_d_nest_minquotient
|
||||
! x = all 3s, y = all 6s => min(x/y) = 0.5
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T09: psb_d_nest_minquotient (x=3 y=6 => 0.5)'
|
||||
|
||||
call set_nest_val(xnest, 3.0_psb_dpk_)
|
||||
call set_nest_val(ynest, 6.0_psb_dpk_)
|
||||
|
||||
res = psb_d_nest_minquotient(xnest, ynest, descs, info)
|
||||
expected = 0.5_psb_dpk_
|
||||
call check('T09 minquotient', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T10: psb_d_nest_gemlt
|
||||
! x = all 2s, y = all 4s => y = y * x = 8 (result in y)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T10: psb_d_nest_gemlt (x=2 y=4 => y=8)'
|
||||
|
||||
call set_nest_val(xnest, 2.0_psb_dpk_)
|
||||
call set_nest_val(ynest, 4.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_gemlt(xnest, ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = 8.0_psb_dpk_
|
||||
res = psb_d_nest_geamax(ynest, descs, info)
|
||||
call check('T10 gemlt amax(y)=8', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(ynest, descs, info)
|
||||
call check('T10 gemlt amin(y)=8', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T11: psb_d_nest_gediv
|
||||
! x = all 6s, y = all 3s => x = x / y = 2 (result in x)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T11: psb_d_nest_gediv (x=6 y=3 => x=2)'
|
||||
|
||||
call set_nest_val(xnest, 6.0_psb_dpk_)
|
||||
call set_nest_val(ynest, 3.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_gediv(xnest, ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = 2.0_psb_dpk_
|
||||
res = psb_d_nest_geamax(xnest, descs, info)
|
||||
call check('T11 gediv amax(x)=2', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(xnest, descs, info)
|
||||
call check('T11 gediv amin(x)=2', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T12: psb_d_nest_geinv
|
||||
! x = all 4s => y = 1/x = 0.25 (result in y)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T12: psb_d_nest_geinv (x=4 => y=0.25)'
|
||||
|
||||
call set_nest_val(xnest, 4.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_geinv(xnest, ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = 0.25_psb_dpk_
|
||||
res = psb_d_nest_geamax(ynest, descs, info)
|
||||
call check('T12 geinv amax(y)=0.25', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(ynest, descs, info)
|
||||
call check('T12 geinv amin(y)=0.25', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T13: psb_d_nest_geabs
|
||||
! x = all -3s => y = |x| = 3 (result in y)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T13: psb_d_nest_geabs (x=-3 => y=3)'
|
||||
|
||||
call set_nest_val(xnest, -3.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_geabs(xnest, ynest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = 3.0_psb_dpk_
|
||||
res = psb_d_nest_geamax(ynest, descs, info)
|
||||
call check('T13 geabs amax(y)=3', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(ynest, descs, info)
|
||||
call check('T13 geabs amin(y)=3', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T14: psb_d_nest_geaddconst
|
||||
! x = all 2s, b = 7.0 => z = x + 7 = 9 (result in z)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T14: psb_d_nest_geaddconst (x=2 b=7 => z=9)'
|
||||
|
||||
call set_nest_val(xnest, 2.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_geaddconst(xnest, 7.0_psb_dpk_, znest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = 9.0_psb_dpk_
|
||||
res = psb_d_nest_geamax(znest, descs, info)
|
||||
call check('T14 geaddconst amax(z)=9', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(znest, descs, info)
|
||||
call check('T14 geaddconst amin(z)=9', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T15a: psb_d_nest_gecmp — entries satisfy threshold
|
||||
! x = all 3s, c = 2.0 => z(i)=1 (since |3| >= 2)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T15a: psb_d_nest_gecmp (x=3 c=2 => z=1)'
|
||||
|
||||
call set_nest_val(xnest, 3.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_gecmp(xnest, 2.0_psb_dpk_, znest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = done
|
||||
res = psb_d_nest_geamax(znest, descs, info)
|
||||
call check('T15a gecmp amax(z)=1', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(znest, descs, info)
|
||||
call check('T15a gecmp amin(z)=1', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T15b: psb_d_nest_gecmp — entries do not satisfy threshold
|
||||
! x = all 1s, c = 2.0 => z(i)=0 (since |1| < 2)
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T15b: psb_d_nest_gecmp (x=1 c=2 => z=0)'
|
||||
|
||||
call set_nest_val(xnest, done)
|
||||
|
||||
call psb_d_nest_gecmp(xnest, 2.0_psb_dpk_, znest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = dzero
|
||||
res = psb_d_nest_geamax(znest, descs, info)
|
||||
call check('T15b gecmp amax(z)=0', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! T16: psb_d_nest_mask
|
||||
! Semantics: mask(c, x, m, t)
|
||||
! c = values to test (first arg)
|
||||
! x = constraint-type indicators (second arg):
|
||||
! 2 => satisfied if c(i) > 0
|
||||
! 1 => satisfied if c(i) >= 0
|
||||
! -1 => satisfied if c(i) <= 0
|
||||
! -2 => satisfied if c(i) < 0
|
||||
! m = output mask (0=satisfied, 1=violated)
|
||||
! t = .true. iff all entries satisfied
|
||||
!
|
||||
! Case: c = all +3 (positive), x = all 2 (check > 0) => m=0 t=T
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') 'T16: psb_d_nest_mask (c=3 x=2 => m=0 t=.true.)'
|
||||
|
||||
call set_nest_val(xnest, 3.0_psb_dpk_) ! values to test
|
||||
call set_nest_val(ynest, 2.0_psb_dpk_) ! constraint indicators (type 2: check > 0)
|
||||
|
||||
call psb_d_nest_mask(xnest, ynest, znest, t_mask, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
if (iam == 0) then
|
||||
if (t_mask) then
|
||||
write(*,'(a)') ' T16 mask: t=.true. PASS (all constraints satisfied)'
|
||||
npass = npass + 1
|
||||
else
|
||||
write(*,'(a)') ' T16 mask: t=.false. FAIL (expected .true.)'
|
||||
nfail = nfail + 1
|
||||
end if
|
||||
end if
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! T16b: c = all -3 (negative), x = all 2 (check > 0) => m=1 t=F
|
||||
!------------------------------------------------------------------
|
||||
if (iam == 0) write(*,'(a)') 'T16b: psb_d_nest_mask (c=-3 x=2 => m=1 t=.false.)'
|
||||
|
||||
call set_nest_val(xnest, -3.0_psb_dpk_) ! values (negative)
|
||||
call set_nest_val(ynest, 2.0_psb_dpk_) ! indicators (type 2: check > 0)
|
||||
|
||||
call psb_d_nest_mask(xnest, ynest, znest, t_mask, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
if (iam == 0) then
|
||||
if (.not. t_mask) then
|
||||
write(*,'(a)') ' T16b mask: t=.false. PASS (all constraints violated)'
|
||||
npass = npass + 1
|
||||
else
|
||||
write(*,'(a)') ' T16b mask: t=.true. FAIL (expected .false.)'
|
||||
nfail = nfail + 1
|
||||
end if
|
||||
end if
|
||||
|
||||
!==================================================================
|
||||
! T17: psb_d_nest_upd_xyz
|
||||
! Computes: y_new = alpha*x + beta*y
|
||||
! z_new = gamma*y_new + delta*z
|
||||
!
|
||||
! x=1, y=2, z=3, alpha=2, beta=3, gamma=4, delta=5
|
||||
! => y_new = 2*1 + 3*2 = 8
|
||||
! => z_new = 4*8 + 5*3 = 47
|
||||
!==================================================================
|
||||
if (iam == 0) write(*,'(/,a)') repeat('=',60)
|
||||
if (iam == 0) write(*,'(a)') &
|
||||
'T17: psb_d_nest_upd_xyz (x=1 y=2 z=3 a=2 b=3 g=4 d=5 => y=8 z=47)'
|
||||
|
||||
call set_nest_val(xnest, done)
|
||||
call set_nest_val(ynest, 2.0_psb_dpk_)
|
||||
call set_nest_val(znest, 3.0_psb_dpk_)
|
||||
|
||||
call psb_d_nest_upd_xyz(2.0_psb_dpk_, 3.0_psb_dpk_, &
|
||||
& 4.0_psb_dpk_, 5.0_psb_dpk_, &
|
||||
& xnest, ynest, znest, descs, info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
expected = 8.0_psb_dpk_
|
||||
res = psb_d_nest_geamax(ynest, descs, info)
|
||||
call check('T17 upd_xyz amax(y)=8', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(ynest, descs, info)
|
||||
call check('T17 upd_xyz amin(y)=8', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
expected = 47.0_psb_dpk_
|
||||
res = psb_d_nest_geamax(znest, descs, info)
|
||||
call check('T17 upd_xyz amax(z)=47', res, expected, tol, npass, nfail, iam)
|
||||
res = psb_d_nest_gemin(znest, descs, info)
|
||||
call check('T17 upd_xyz amin(z)=47', res, expected, tol, npass, nfail, iam)
|
||||
|
||||
!==================================================================
|
||||
! Summary
|
||||
!==================================================================
|
||||
if (iam == 0) then
|
||||
write(*,'(/,a)') repeat('=',60)
|
||||
write(*,'(a,i0,a,i0,a)') &
|
||||
' RESULTS: ', npass, ' passed, ', nfail, ' failed'
|
||||
write(*,'(a)') repeat('=',60)
|
||||
end if
|
||||
|
||||
!==================================================================
|
||||
! Clean up
|
||||
!==================================================================
|
||||
call psb_gefree_nest(xnest, descs, info)
|
||||
call psb_gefree_nest(ynest, descs, info)
|
||||
call psb_gefree_nest(znest, descs, info)
|
||||
|
||||
call psb_cdfree(desc1, info)
|
||||
call psb_cdfree(desc2, info)
|
||||
call psb_cdfree(desc3, info)
|
||||
call psb_cdfree(desc4, info)
|
||||
|
||||
call psb_exit(ctxt)
|
||||
stop
|
||||
|
||||
9999 continue
|
||||
write(psb_err_unit,*) trim(name), ': error info=', info, ' rank=', iam
|
||||
call psb_error(ctxt)
|
||||
call psb_exit(ctxt)
|
||||
stop
|
||||
|
||||
contains
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Set every local entry of every block to val
|
||||
!------------------------------------------------------------------
|
||||
subroutine set_nest_val(v, val)
|
||||
use psb_base_mod
|
||||
type(psb_d_nest_vect_type), intent(inout) :: v
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_) :: k, linfo
|
||||
linfo = 0
|
||||
do k = 1, v%nblocks
|
||||
call v%vects(k)%set(val, linfo)
|
||||
end do
|
||||
end subroutine set_nest_val
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Scalar pass/fail check with tolerance
|
||||
!------------------------------------------------------------------
|
||||
subroutine check(label, got, expected, tol, np_, nf_, myrank)
|
||||
use psb_base_mod
|
||||
character(len=*), intent(in) :: label
|
||||
real(psb_dpk_), intent(in) :: got, expected, tol
|
||||
integer(psb_ipk_), intent(inout) :: np_, nf_
|
||||
integer(psb_ipk_), intent(in) :: myrank
|
||||
|
||||
if (myrank /= 0) return
|
||||
if (abs(got - expected) <= tol * max(done, abs(expected))) then
|
||||
write(*,'(2x,a,a,f16.10,a,f16.10)') &
|
||||
'PASS ', trim(label)//' got=', got, ' exp=', expected
|
||||
np_ = np_ + 1
|
||||
else
|
||||
write(*,'(2x,a,a,f16.10,a,f16.10)') &
|
||||
'FAIL ', trim(label)//' got=', got, ' exp=', expected
|
||||
nf_ = nf_ + 1
|
||||
end if
|
||||
end subroutine check
|
||||
|
||||
!------------------------------------------------------------------
|
||||
! Print every block of a nested vector (one rank at a time).
|
||||
! Each process flushes stdout before the barrier so that buffered
|
||||
! output does not bleed into the next process's print window.
|
||||
!------------------------------------------------------------------
|
||||
subroutine print_nest_vec(v, label, myrank, nprocs, myctxt, ds)
|
||||
use psb_base_mod
|
||||
use iso_fortran_env, only: output_unit
|
||||
type(psb_d_nest_vect_type), intent(inout) :: v
|
||||
character(len=*), intent(in) :: label
|
||||
integer(psb_ipk_), intent(in) :: myrank, nprocs
|
||||
type(psb_ctxt_type), intent(in) :: myctxt
|
||||
type(psb_desc_nest_type), intent(in) :: ds
|
||||
|
||||
integer(psb_ipk_) :: blk, ip, k, nr, linfo
|
||||
real(psb_dpk_), allocatable :: vals(:)
|
||||
|
||||
do blk = 1, v%nblocks
|
||||
nr = ds%descs(blk,blk)%get_local_rows()
|
||||
do ip = 0, nprocs-1
|
||||
call psb_barrier(myctxt)
|
||||
if (myrank == ip) then
|
||||
write(*,'(a,a,a,i0,a)') ' [', trim(label), '] block ', blk, ':'
|
||||
linfo = 0
|
||||
allocate(vals(nr), stat=linfo)
|
||||
if (linfo == 0) vals = v%vects(blk)%get_vect()
|
||||
do k = 1, nr
|
||||
write(*,'(4x,i4,f14.6)') k, vals(k)
|
||||
end do
|
||||
deallocate(vals)
|
||||
flush(output_unit)
|
||||
end if
|
||||
end do
|
||||
call psb_barrier(myctxt)
|
||||
end do
|
||||
end subroutine print_nest_vec
|
||||
|
||||
end program psb_d_pde_nest_psblas
|
||||
Reference in New Issue
Block a user