From e1d759d019a56e2e695254ac461b527bbfa47e51 Mon Sep 17 00:00:00 2001 From: Stack-1 Date: Sat, 13 Jun 2026 01:58:38 +0200 Subject: [PATCH] [ADD] Generate the nested matrix support for s/c/z from the templates Extend the nested (MATNEST) matrix support to all the arithmetics: the psb_{s,c,z}_nest_{mat,base_mat,tools,builder}_mod modules and the psb_{s,c,z}_nest_mod umbrellas are generated from the template-psblas X_nest_* templates; the d sources are regenerated byte-identical. Preparatory changes to the d sources for clean templating: rowsum/arwsum and colsum/aclsum no longer share a helper (for the complex arithmetics the absolute sums are real-valued while the plain sums are complex-valued), the transposed kernel forwards the actual 'T'/'C' character to the blocks (conjugate transpose for the complex types), and the capacity helper takes a type-neutral name. Build hooks (autotools Makefile and CMakeLists) updated with the per-arith objects, compile rules and dependencies. All four d tests keep passing. Author: Simone Staccone (Stack-1) --- base/CMakeLists.txt | 15 + base/modules/Makefile | 78 +- base/modules/psb_c_nest_mod.f90 | 49 + base/modules/psb_s_nest_mod.f90 | 49 + base/modules/psb_z_nest_mod.f90 | 49 + .../serial/psb_c_nest_base_mat_mod.F90 | 1212 +++++++++++++++++ base/modules/serial/psb_c_nest_mat_mod.f90 | 149 ++ .../serial/psb_d_nest_base_mat_mod.F90 | 97 +- .../serial/psb_s_nest_base_mat_mod.F90 | 1212 +++++++++++++++++ base/modules/serial/psb_s_nest_mat_mod.f90 | 149 ++ .../serial/psb_z_nest_base_mat_mod.F90 | 1212 +++++++++++++++++ base/modules/serial/psb_z_nest_mat_mod.f90 | 149 ++ base/modules/tools/psb_c_nest_builder_mod.F90 | 414 ++++++ base/modules/tools/psb_c_nest_tools_mod.F90 | 364 +++++ base/modules/tools/psb_d_nest_builder_mod.F90 | 6 +- base/modules/tools/psb_s_nest_builder_mod.F90 | 414 ++++++ base/modules/tools/psb_s_nest_tools_mod.F90 | 364 +++++ base/modules/tools/psb_z_nest_builder_mod.F90 | 414 ++++++ base/modules/tools/psb_z_nest_tools_mod.F90 | 364 +++++ 19 files changed, 6712 insertions(+), 48 deletions(-) create mode 100644 base/modules/psb_c_nest_mod.f90 create mode 100644 base/modules/psb_s_nest_mod.f90 create mode 100644 base/modules/psb_z_nest_mod.f90 create mode 100644 base/modules/serial/psb_c_nest_base_mat_mod.F90 create mode 100644 base/modules/serial/psb_c_nest_mat_mod.f90 create mode 100644 base/modules/serial/psb_s_nest_base_mat_mod.F90 create mode 100644 base/modules/serial/psb_s_nest_mat_mod.f90 create mode 100644 base/modules/serial/psb_z_nest_base_mat_mod.F90 create mode 100644 base/modules/serial/psb_z_nest_mat_mod.f90 create mode 100644 base/modules/tools/psb_c_nest_builder_mod.F90 create mode 100644 base/modules/tools/psb_c_nest_tools_mod.F90 create mode 100644 base/modules/tools/psb_s_nest_builder_mod.F90 create mode 100644 base/modules/tools/psb_s_nest_tools_mod.F90 create mode 100644 base/modules/tools/psb_z_nest_builder_mod.F90 create mode 100644 base/modules/tools/psb_z_nest_tools_mod.F90 diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index d60799367..e70c632e0 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -568,8 +568,14 @@ set(PSB_base_source_files modules/tools/psb_cd_tools_mod.F90 modules/tools/psb_d_tools_mod.F90 modules/tools/psb_cd_nest_tools_mod.F90 + modules/tools/psb_s_nest_tools_mod.F90 modules/tools/psb_d_nest_tools_mod.F90 + modules/tools/psb_c_nest_tools_mod.F90 + modules/tools/psb_z_nest_tools_mod.F90 + modules/tools/psb_s_nest_builder_mod.F90 modules/tools/psb_d_nest_builder_mod.F90 + modules/tools/psb_c_nest_builder_mod.F90 + modules/tools/psb_z_nest_builder_mod.F90 modules/tools/psb_c_tools_mod.F90 modules/tools/psb_e_tools_a_mod.f90 modules/tools/psb_i2_tools_a_mod.f90 @@ -642,9 +648,18 @@ set(PSB_base_source_files modules/desc/psb_glist_map_mod.F90 modules/psb_base_mod.f90 modules/desc/psb_desc_nest_mod.f90 + modules/serial/psb_s_nest_mat_mod.f90 modules/serial/psb_d_nest_mat_mod.f90 + modules/serial/psb_c_nest_mat_mod.f90 + modules/serial/psb_z_nest_mat_mod.f90 + modules/serial/psb_s_nest_base_mat_mod.F90 modules/serial/psb_d_nest_base_mat_mod.F90 + modules/serial/psb_c_nest_base_mat_mod.F90 + modules/serial/psb_z_nest_base_mat_mod.F90 + modules/psb_s_nest_mod.f90 modules/psb_d_nest_mod.f90 + modules/psb_c_nest_mod.f90 + modules/psb_z_nest_mod.f90 ) foreach(file IN LISTS PSB_base_source_files) list(APPEND base_source_files ${CMAKE_CURRENT_LIST_DIR}/${file}) diff --git a/base/modules/Makefile b/base/modules/Makefile index 27ded2451..cad174126 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -84,7 +84,10 @@ SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_mat_mod.o \ serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_mat_mod.o \ serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o \ - serial/psb_d_nest_mat_mod.o serial/psb_d_nest_base_mat_mod.o + serial/psb_s_nest_mat_mod.o serial/psb_s_nest_base_mat_mod.o \ + serial/psb_d_nest_mat_mod.o serial/psb_d_nest_base_mat_mod.o \ + serial/psb_c_nest_mat_mod.o serial/psb_c_nest_base_mat_mod.o \ + serial/psb_z_nest_mat_mod.o serial/psb_z_nest_base_mat_mod.o #\ # serial/psb_ls_csr_mat_mod.o serial/psb_ld_csr_mat_mod.o serial/psb_lc_csr_mat_mod.o serial/psb_lz_csr_mat_mod.o #\ @@ -98,8 +101,10 @@ UTIL_MODS = desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ tools/psb_cd_nest_tools_mod.o \ tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ - tools/psb_d_nest_tools_mod.o \ - tools/psb_d_nest_builder_mod.o \ + tools/psb_s_nest_tools_mod.o tools/psb_d_nest_tools_mod.o \ + tools/psb_c_nest_tools_mod.o tools/psb_z_nest_tools_mod.o \ + tools/psb_s_nest_builder_mod.o tools/psb_d_nest_builder_mod.o \ + tools/psb_c_nest_builder_mod.o tools/psb_z_nest_builder_mod.o \ tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ tools/psb_i2_tools_a_mod.o tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ @@ -133,7 +138,7 @@ UTIL_MODS = desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ MODULES=$(BASIC_MODS) $(SERIAL_MODS) $(UTIL_MODS) -OBJS = error.o psb_base_mod.o psb_d_nest_mod.o $(EXTRA_COBJS) cutil.o +OBJS = error.o psb_base_mod.o psb_s_nest_mod.o psb_d_nest_mod.o psb_c_nest_mod.o psb_z_nest_mod.o $(EXTRA_COBJS) cutil.o MODDIR=../../modules INCDIR=../../include LIBDIR=../ @@ -418,7 +423,9 @@ comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \ comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o: desc/psb_desc_mod.o tools/psb_tools_mod.o: tools/psb_cd_tools_mod.o tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ - tools/psb_cd_nest_tools_mod.o tools/psb_d_nest_tools_mod.o \ + tools/psb_cd_nest_tools_mod.o \ + tools/psb_s_nest_tools_mod.o tools/psb_d_nest_tools_mod.o \ + tools/psb_c_nest_tools_mod.o tools/psb_z_nest_tools_mod.o \ tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ tools/psb_i2_tools_a_mod.o tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ @@ -433,10 +440,39 @@ tools/psb_d_nest_tools_mod.o: tools/psb_d_nest_tools_mod.F90 tools/psb_d_tools_m $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_d_nest_tools_mod.F90 -o tools/psb_d_nest_tools_mod.o tools/psb_d_nest_builder_mod.o: tools/psb_d_nest_builder_mod.F90 tools/psb_cd_tools_mod.o \ - tools/psb_cd_nest_tools_mod.o tools/psb_d_nest_tools_mod.o \ + tools/psb_cd_nest_tools_mod.o \ + tools/psb_s_nest_tools_mod.o tools/psb_d_nest_tools_mod.o \ + tools/psb_c_nest_tools_mod.o tools/psb_z_nest_tools_mod.o \ serial/psb_d_nest_base_mat_mod.o serial/psb_d_nest_mat_mod.o desc/psb_desc_nest_mod.o $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_d_nest_builder_mod.F90 -o tools/psb_d_nest_builder_mod.o +tools/psb_s_nest_tools_mod.o: tools/psb_s_nest_tools_mod.F90 tools/psb_s_tools_mod.o \ + desc/psb_desc_nest_mod.o serial/psb_s_nest_mat_mod.o + $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_s_nest_tools_mod.F90 -o tools/psb_s_nest_tools_mod.o + +tools/psb_s_nest_builder_mod.o: tools/psb_s_nest_builder_mod.F90 tools/psb_cd_tools_mod.o \ + tools/psb_cd_nest_tools_mod.o tools/psb_s_nest_tools_mod.o \ + serial/psb_s_nest_base_mat_mod.o serial/psb_s_nest_mat_mod.o desc/psb_desc_nest_mod.o + $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_s_nest_builder_mod.F90 -o tools/psb_s_nest_builder_mod.o + +tools/psb_c_nest_tools_mod.o: tools/psb_c_nest_tools_mod.F90 tools/psb_c_tools_mod.o \ + desc/psb_desc_nest_mod.o serial/psb_c_nest_mat_mod.o + $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_c_nest_tools_mod.F90 -o tools/psb_c_nest_tools_mod.o + +tools/psb_c_nest_builder_mod.o: tools/psb_c_nest_builder_mod.F90 tools/psb_cd_tools_mod.o \ + tools/psb_cd_nest_tools_mod.o tools/psb_c_nest_tools_mod.o \ + serial/psb_c_nest_base_mat_mod.o serial/psb_c_nest_mat_mod.o desc/psb_desc_nest_mod.o + $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_c_nest_builder_mod.F90 -o tools/psb_c_nest_builder_mod.o + +tools/psb_z_nest_tools_mod.o: tools/psb_z_nest_tools_mod.F90 tools/psb_z_tools_mod.o \ + desc/psb_desc_nest_mod.o serial/psb_z_nest_mat_mod.o + $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_z_nest_tools_mod.F90 -o tools/psb_z_nest_tools_mod.o + +tools/psb_z_nest_builder_mod.o: tools/psb_z_nest_builder_mod.F90 tools/psb_cd_tools_mod.o \ + tools/psb_cd_nest_tools_mod.o tools/psb_z_nest_tools_mod.o \ + serial/psb_z_nest_base_mat_mod.o serial/psb_z_nest_mat_mod.o desc/psb_desc_nest_mod.o + $(FC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c tools/psb_z_nest_builder_mod.F90 -o tools/psb_z_nest_builder_mod.o + tools/psb_cd_tools_mod.o tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o \ tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ @@ -459,6 +495,36 @@ psblas/psb_psblas_mod.o: psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o ps psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o psblas/psb_d_psblas_mod.o psblas/psb_z_psblas_mod.o: serial/psb_mat_mod.o desc/psb_desc_mod.o # --- nested mat/desc dependencies (MATNEST) --- +serial/psb_s_nest_mat_mod.o: serial/psb_s_mat_mod.o +serial/psb_s_nest_base_mat_mod.o: serial/psb_s_nest_mat_mod.o desc/psb_desc_nest_mod.o serial/psb_s_base_mat_mod.o serial/psb_s_mat_mod.o desc/psb_desc_mod.o \ + serial/psb_i_vect_mod.o serial/psb_s_base_vect_mod.o +psb_s_nest_mod.o: \ + desc/psb_desc_nest_mod.o \ + serial/psb_s_nest_mat_mod.o \ + serial/psb_s_nest_base_mat_mod.o \ + tools/psb_cd_nest_tools_mod.o \ + tools/psb_s_nest_tools_mod.o \ + tools/psb_s_nest_builder_mod.o +serial/psb_c_nest_mat_mod.o: serial/psb_c_mat_mod.o +serial/psb_c_nest_base_mat_mod.o: serial/psb_c_nest_mat_mod.o desc/psb_desc_nest_mod.o serial/psb_c_base_mat_mod.o serial/psb_c_mat_mod.o desc/psb_desc_mod.o \ + serial/psb_i_vect_mod.o serial/psb_c_base_vect_mod.o +psb_c_nest_mod.o: \ + desc/psb_desc_nest_mod.o \ + serial/psb_c_nest_mat_mod.o \ + serial/psb_c_nest_base_mat_mod.o \ + tools/psb_cd_nest_tools_mod.o \ + tools/psb_c_nest_tools_mod.o \ + tools/psb_c_nest_builder_mod.o +serial/psb_z_nest_mat_mod.o: serial/psb_z_mat_mod.o +serial/psb_z_nest_base_mat_mod.o: serial/psb_z_nest_mat_mod.o desc/psb_desc_nest_mod.o serial/psb_z_base_mat_mod.o serial/psb_z_mat_mod.o desc/psb_desc_mod.o \ + serial/psb_i_vect_mod.o serial/psb_z_base_vect_mod.o +psb_z_nest_mod.o: \ + desc/psb_desc_nest_mod.o \ + serial/psb_z_nest_mat_mod.o \ + serial/psb_z_nest_base_mat_mod.o \ + tools/psb_cd_nest_tools_mod.o \ + tools/psb_z_nest_tools_mod.o \ + tools/psb_z_nest_builder_mod.o desc/psb_desc_nest_mod.o: desc/psb_desc_mod.o serial/psb_d_nest_mat_mod.o: serial/psb_d_mat_mod.o serial/psb_d_nest_base_mat_mod.o: serial/psb_d_nest_mat_mod.o desc/psb_desc_nest_mod.o serial/psb_d_base_mat_mod.o serial/psb_d_mat_mod.o desc/psb_desc_mod.o \ diff --git a/base/modules/psb_c_nest_mod.f90 b/base/modules/psb_c_nest_mod.f90 new file mode 100644 index 000000000..253085dff --- /dev/null +++ b/base/modules/psb_c_nest_mod.f90 @@ -0,0 +1,49 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! module: psb_c_nest_mod +! Author: Simone Staccone (Stack-1) +! +! Umbrella module for the nested (block-structured) double precision +! real types. Users need only: +! +! use psb_c_nest_mod +! +! to access all three container types and their parallel operations. +! +module psb_c_nest_mod + use psb_desc_nest_mod ! grid descriptor (per-field, input to compose) + use psb_c_nest_mat_mod ! block storage (psb_c_nest_sparse_mat) + use psb_c_nest_base_mat_mod ! MATNEST operator + field-split interface + use psb_cd_nest_tools_mod ! psb_cd_nest_compose (global descriptor) + use psb_c_nest_tools_mod ! block assembly + psb_c_nest_rect_block + use psb_c_nest_builder_mod ! psb_c_nest_matrix: init/ins/asb frontend +end module psb_c_nest_mod diff --git a/base/modules/psb_s_nest_mod.f90 b/base/modules/psb_s_nest_mod.f90 new file mode 100644 index 000000000..46af70942 --- /dev/null +++ b/base/modules/psb_s_nest_mod.f90 @@ -0,0 +1,49 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! module: psb_s_nest_mod +! Author: Simone Staccone (Stack-1) +! +! Umbrella module for the nested (block-structured) double precision +! real types. Users need only: +! +! use psb_s_nest_mod +! +! to access all three container types and their parallel operations. +! +module psb_s_nest_mod + use psb_desc_nest_mod ! grid descriptor (per-field, input to compose) + use psb_s_nest_mat_mod ! block storage (psb_s_nest_sparse_mat) + use psb_s_nest_base_mat_mod ! MATNEST operator + field-split interface + use psb_cd_nest_tools_mod ! psb_cd_nest_compose (global descriptor) + use psb_s_nest_tools_mod ! block assembly + psb_s_nest_rect_block + use psb_s_nest_builder_mod ! psb_s_nest_matrix: init/ins/asb frontend +end module psb_s_nest_mod diff --git a/base/modules/psb_z_nest_mod.f90 b/base/modules/psb_z_nest_mod.f90 new file mode 100644 index 000000000..0ee79a023 --- /dev/null +++ b/base/modules/psb_z_nest_mod.f90 @@ -0,0 +1,49 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! module: psb_z_nest_mod +! Author: Simone Staccone (Stack-1) +! +! Umbrella module for the nested (block-structured) double precision +! real types. Users need only: +! +! use psb_z_nest_mod +! +! to access all three container types and their parallel operations. +! +module psb_z_nest_mod + use psb_desc_nest_mod ! grid descriptor (per-field, input to compose) + use psb_z_nest_mat_mod ! block storage (psb_z_nest_sparse_mat) + use psb_z_nest_base_mat_mod ! MATNEST operator + field-split interface + use psb_cd_nest_tools_mod ! psb_cd_nest_compose (global descriptor) + use psb_z_nest_tools_mod ! block assembly + psb_z_nest_rect_block + use psb_z_nest_builder_mod ! psb_z_nest_matrix: init/ins/asb frontend +end module psb_z_nest_mod diff --git a/base/modules/serial/psb_c_nest_base_mat_mod.F90 b/base/modules/serial/psb_c_nest_base_mat_mod.F90 new file mode 100644 index 000000000..2e3ef93cb --- /dev/null +++ b/base/modules/serial/psb_c_nest_base_mat_mod.F90 @@ -0,0 +1,1212 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_c_nest_base_mat_mod.F90 +! +! Module: psb_c_nest_base_mat_mod +! Author: Simone Staccone (Stack-1) +! +! Adapter that makes a block-structured (nested) operator look like a standard +! local sparse matrix to PSBLAS: psb_c_nest_base_mat EXTENDS +! psb_c_base_sparse_mat and implements csmv (the local matrix-vector product). +! Wrapped in a psb_cspmat_type and paired with the composed global descriptor +! (see psb_cd_nest_compose), the nested operator can then be fed to psb_spmm, +! psb_krylov and the AMG4PSBLAS preconditioners unchanged (MATNEST-style). +! +! The local vector handed to csmv lives in the GLOBAL local layout produced by +! psb_cd_nest_compose: the owned entries of all fields are concatenated, followed +! by the global halo. For each field we precompute field_map(field)%global_local_pos, +! the positions in that global local vector of the field's own local vector +! (owned entries first, then the field's ghosts), so we can gather the field +! input sub-vector and scatter the field output sub-vector without further +! communication (the halo exchange is done once by psb_spmm on the global desc). +! +module psb_c_nest_base_mat_mod + use psb_const_mod + use psb_error_mod + use psb_realloc_mod, only : psb_ensure_size + use psb_c_base_mat_mod, only : psb_c_base_sparse_mat + use psb_c_base_vect_mod, only : psb_c_base_vect_type + use psb_i_vect_mod, only : psb_i_vect_type + use psb_desc_mod, only : psb_desc_type + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_c_nest_mat_mod, only : psb_c_nest_sparse_mat + use psb_c_mat_mod, only : psb_cspmat_type + implicit none + + ! Per-field gather/scatter map into the global local vector. + ! global_local_pos(1 : n_owned) -> the field's owned entries + ! global_local_pos(n_owned+1 : size) -> the field's ghost (halo) entries + type :: psb_c_nest_field_map + integer(psb_ipk_) :: n_owned = 0 + integer(psb_ipk_), allocatable :: global_local_pos(:) + ! same positions as an encapsulated index vector, for the device-capable + ! gather/scatter (gth/sct) used by vect_mv; pointer so that its target can + ! be synced even when the operator dummy argument is intent(in) + type(psb_i_vect_type), pointer :: gather_pos => null() + end type psb_c_nest_field_map + + type, extends(psb_c_base_sparse_mat) :: psb_c_nest_base_mat + integer(psb_ipk_) :: n_fields = 0 + type(psb_c_nest_sparse_mat), pointer :: block_storage => null() ! blocks (not owned) + type(psb_desc_nest_type), pointer :: grid_desc => null() ! per-field descriptors (not owned) + type(psb_c_nest_field_map), allocatable :: field_map(:) + contains + procedure, pass(a) :: csmv => psb_c_nest_base_csmv + procedure, pass(a) :: get_nzeros => psb_c_nest_base_get_nzeros + procedure, nopass :: get_fmt => psb_c_nest_base_get_fmt + procedure, pass(a) :: free => psb_c_nest_base_free + ! enable the stock PSBLAS preconditioners on the nested operator: + ! get_diag is used by DIAG/JACOBI, csgetrow by BJAC (ILU factorizations + ! go through the format-agnostic csget path) + procedure, pass(a) :: get_diag => psb_c_nest_base_get_diag + procedure, pass(a) :: csgetrow => psb_c_nest_base_csgetrow + ! device-capable matvec on encapsulated vectors: gathers/scatters through + ! the vectors' own gth/sct and runs each block through its vect_mv, so + ! device block formats execute their device kernels + procedure, pass(a) :: vect_mv => psb_c_nest_base_vect_mv + ! full base-class contract (delegating to the blocks): + procedure, pass(a) :: csmm => psb_c_nest_base_csmm + procedure, pass(a) :: cp_to_coo => psb_c_nest_base_cp_to_coo + procedure, pass(a) :: mv_to_coo => psb_c_nest_base_mv_to_coo + procedure, pass(a) :: rowsum => psb_c_nest_base_rowsum + procedure, pass(a) :: arwsum => psb_c_nest_base_arwsum + procedure, pass(a) :: colsum => psb_c_nest_base_colsum + procedure, pass(a) :: aclsum => psb_c_nest_base_aclsum + procedure, pass(a) :: maxval => psb_c_nest_base_maxval + procedure, pass(a) :: spnmi => psb_c_nest_base_csnmi + procedure, pass(a) :: spnm1 => psb_c_nest_base_csnm1 + procedure, pass(a) :: scals => psb_c_nest_base_scals + procedure, pass(a) :: scalv => psb_c_nest_base_scal + procedure, pass(a) :: clone => psb_c_nest_base_clone + procedure, pass(a) :: mold => psb_c_nest_base_mold + procedure, pass(a) :: sizeof => psb_c_nest_base_sizeof + ! NOT implemented on purpose (base error 700 is the intended behaviour): + ! cp_from_coo / mv_from_coo (a nested operator cannot be built from a flat + ! matrix without the field structure), csput (insertions go to the blocks + ! before assembly), cssv/cssm (triangular solve is undefined for a block + ! operator) + end type psb_c_nest_base_mat + + private + public :: psb_c_nest_base_mat, psb_c_nest_base_setup, psb_c_nest_apply_block + ! field-split interface (for the block preconditioner) + public :: psb_c_nest_get_n_fields, psb_c_nest_get_field_owned, & + & psb_c_nest_get_block, psb_c_nest_get_field_desc, & + & psb_c_nest_restrict_field, psb_c_nest_prolong_field + +contains + + function psb_c_nest_base_get_fmt() result(format_name) + character(len=5) :: format_name + format_name = 'NEST' + end function psb_c_nest_base_get_fmt + + ! free: the nested operator does NOT own block_storage / grid_desc (they are + ! pointers into the caller), so we only detach them and release the field maps. + subroutine psb_c_nest_base_free(a) + class(psb_c_nest_base_mat), intent(inout) :: a + integer(psb_ipk_) :: i_field, local_info + if (allocated(a%field_map)) then + do i_field = 1, size(a%field_map) + if (associated(a%field_map(i_field)%gather_pos)) then + call a%field_map(i_field)%gather_pos%free(local_info) + deallocate(a%field_map(i_field)%gather_pos) + a%field_map(i_field)%gather_pos => null() + end if + end do + deallocate(a%field_map) + end if + a%block_storage => null() + a%grid_desc => null() + a%n_fields = 0 + call a%set_null() + end subroutine psb_c_nest_base_free + + function psb_c_nest_base_get_nzeros(a) result(total_nzeros) + class(psb_c_nest_base_mat), intent(in) :: a + integer(psb_ipk_) :: total_nzeros + integer(psb_ipk_) :: i_block_row, j_block_col + total_nzeros = 0 + if (associated(a%block_storage)) then + do j_block_col = 1, a%block_storage%ncblocks + do i_block_row = 1, a%block_storage%nrblocks + if (a%block_storage%has_block(i_block_row, j_block_col)) & + & total_nzeros = total_nzeros + & + & a%block_storage%mats(i_block_row, j_block_col)%get_nzeros() + end do + end do + end if + end function psb_c_nest_base_get_nzeros + + ! get_diag: diagonal of the global operator. In the global-local layout the + ! owned entries of field i occupy positions owned_offset+1..owned_offset+n_owned, + ! and for owned indices the field-local column k maps to the same global-local + ! position as row k, so the global diagonal is the concatenation of the + ! diagonals of the diagonal blocks (i,i); absent blocks contribute zeros + ! (e.g. the (2,2) block of a saddle-point operator). + subroutine psb_c_nest_base_get_diag(a, d, info) + class(psb_c_nest_base_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + complex(psb_spk_), allocatable :: block_diag(:) + integer(psb_ipk_) :: i_field, n_owned, owned_offset + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_get_diag' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (size(d) < a%get_nrows()) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='d too small') + return + end if + + d(1:a%get_nrows()) = czero + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + if (a%block_storage%has_block(i_field, i_field)) then + allocate(block_diag(n_owned), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call a%block_storage%mats(i_field,i_field)%a%get_diag(block_diag, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block get_diag') + return + end if + d(owned_offset+1 : owned_offset+n_owned) = block_diag(1:n_owned) + deallocate(block_diag) + end if + owned_offset = owned_offset + n_owned + end do + end subroutine psb_c_nest_base_get_diag + + ! csgetrow: extract local rows imin..imax of the global operator as COO + ! triplets, with columns in the global-local layout (the operator's column + ! space). Each global-local row r belongs to one field i (row k within the + ! field); its entries are the union over j of row k of block (i,j), with the + ! block-local column c remapped through field_map(j)%global_local_pos(c). + ! This is the format-agnostic access path used by the ILU factorizations of + ! the BJAC preconditioner (via csget/csgetblk). + subroutine psb_c_nest_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + class(psb_c_nest_base_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale,chksz + + integer(psb_ipk_), allocatable :: block_row_ia(:), block_row_ja(:) + complex(psb_spk_), allocatable :: block_row_val(:) + integer(psb_ipk_) :: jmin_, jmax_, nzin_, out_pos + integer(psb_ipk_) :: r_row, i_field, j_field, k_in_field, owned_offset + integer(psb_ipk_) :: block_nz, t_entry, global_local_col + logical :: append_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_csgetrow' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (present(iren)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='iren not supported'); return + end if + if (present(rscale)) then + if (rscale) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='rscale not supported'); return + end if + end if + if (present(cscale)) then + if (cscale) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='cscale not supported'); return + end if + end if + + jmin_ = 1 + jmax_ = a%get_ncols() + if (present(jmin)) jmin_ = jmin + if (present(jmax)) jmax_ = jmax + append_ = .false. + if (present(append)) append_ = append + nzin_ = 0 + if (append_ .and. present(nzin)) nzin_ = nzin + + nz = 0 + out_pos = nzin_ + + do r_row = max(imin, 1), min(imax, a%get_nrows()) + ! locate the field owning global-local row r_row + owned_offset = 0 + i_field = 0 + do while (i_field < a%n_fields) + i_field = i_field + 1 + if (r_row <= owned_offset + a%field_map(i_field)%n_owned) exit + owned_offset = owned_offset + a%field_map(i_field)%n_owned + end do + k_in_field = r_row - owned_offset + + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%csgetrow(k_in_field, k_in_field, & + & block_nz, block_row_ia, block_row_ja, block_row_val, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csgetrow') + return + end if + do t_entry = 1, block_nz + global_local_col = a%field_map(j_field)%global_local_pos(block_row_ja(t_entry)) + if ((global_local_col < jmin_) .or. (global_local_col > jmax_)) cycle + out_pos = out_pos + 1 + call psb_ensure_size(out_pos, ia, info) + if (info == psb_success_) call psb_ensure_size(out_pos, ja, info) + if (info == psb_success_) call psb_ensure_size(out_pos, val, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ia(out_pos) = r_row + ja(out_pos) = global_local_col + val(out_pos) = block_row_val(t_entry) + nz = nz + 1 + end do + end do + end do + end subroutine psb_c_nest_base_csgetrow + + ! vect_mv: matvec on encapsulated vectors (the path taken by psb_spmm with + ! psb_c_vect_type). Instead of falling back to the host-array csmv, it + ! (1) gathers each column-field sub-vector through the vector's own gth with + ! an encapsulated index vector (a device kernel on device vectors), + ! (2) runs each block through its vect_mv (device formats execute their own + ! device kernels), with per-field work vectors allocated with mold=x so + ! they share the dynamic type of the incoming vectors, + ! (3) scatters each row-field result back through the vector's own sct. + ! Host/device traffic is limited to the compact field buffers; on plain host + ! vectors this is exactly equivalent to the array csmv. + subroutine psb_c_nest_base_vect_mv(alpha, a, x, beta, y, info, trans) + class(psb_c_nest_base_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + class(psb_c_base_vect_type), allocatable :: x_field_vec, y_field_vec + complex(psb_spk_), allocatable :: x_field_buf(:), y_field_buf(:) + complex(psb_spk_) :: block_beta + integer(psb_ipk_) :: i_field, j_field, n_owned, n_local, local_info + logical :: row_has_blocks + character :: trans_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_vect_mv' + + trans_ = 'N' + if (present(trans)) trans_ = trans + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (trans_ /= 'N' .and. trans_ /= 'n') then + ! transposed product: fall back to host arrays (rare path) + block + complex(psb_spk_), allocatable :: x_host(:), y_host(:) + x_host = x%get_vect() + y_host = y%get_vect() + call psb_c_nest_base_csmv_t(alpha, a, x_host, beta, y_host, info, trans_) + call y%bld(y_host) + end block + return + end if + + ! work vectors share the dynamic type of the incoming vectors + allocate(x_field_vec, mold=x, stat=info) + if (info == 0) allocate(y_field_vec, mold=y, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + call psb_ensure_size(n_owned, y_field_buf, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + row_has_blocks = .false. + block_beta = czero + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + + ! gather the column-field sub-vector (owned + ghosts) from x + n_local = size(a%field_map(j_field)%global_local_pos) + call psb_ensure_size(n_local, x_field_buf, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call x%gth(ione, int(n_local, psb_mpk_), & + & a%field_map(j_field)%gather_pos%v, x_field_buf) + call x_field_vec%free(local_info) + call x_field_vec%bld(x_field_buf(1:n_local)) + + if (.not. row_has_blocks) then + ! first block of this row field: (re)build the accumulator at the + ! right size, zeroed + y_field_buf(1:n_owned) = czero + call y_field_vec%free(local_info) + call y_field_vec%bld(y_field_buf(1:n_owned)) + row_has_blocks = .true. + end if + + ! y_field = alpha * A(i,j) * x_field + block_beta * y_field + call a%block_storage%mats(i_field,j_field)%a%spmm(alpha, x_field_vec, & + & block_beta, y_field_vec, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block vect_mv') + return + end if + block_beta = cone + end do + + ! scatter the row-field result into y (beta applied on the owned rows); + ! a row field with no blocks still rescales its rows by beta + if (row_has_blocks) then + y_field_buf(1:n_owned) = y_field_vec%get_vect() + else + y_field_buf(1:n_owned) = czero + end if + call y%sct(ione, int(n_owned, psb_mpk_), & + & a%field_map(i_field)%gather_pos%v, y_field_buf, beta) + end do + + call x_field_vec%free(local_info) + call y_field_vec%free(local_info) + end subroutine psb_c_nest_base_vect_mv + + ! Build the per-field gather maps and set the local dimensions, from the nested + ! grid descriptor (per-field distribution desc_grid%descs(1,field)) and the + ! composed global descriptor desc_global (produced by psb_cd_nest_compose). + subroutine psb_c_nest_base_setup(nest_op, block_storage, desc_grid, desc_global, info) + type(psb_c_nest_base_mat), intent(inout) :: nest_op + type(psb_c_nest_sparse_mat), target, intent(in) :: block_storage + type(psb_desc_nest_type), target, intent(in) :: desc_grid + type(psb_desc_type), intent(in) :: desc_global + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_fields, i_field, i_entry + integer(psb_ipk_) :: n_owned, n_local, n_ghost, owned_offset, local_pos + integer(psb_lpk_) :: global_idx + integer(psb_lpk_), allocatable :: field_global_offset(:) + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_base_setup' + + if (desc_grid%nrblocks /= desc_grid%ncblocks) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested block structure must be square') + return + end if + + n_fields = desc_grid%ncblocks + nest_op%n_fields = n_fields + nest_op%grid_desc => desc_grid + nest_op%block_storage => block_storage + + ! global field offsets (used to form ghost global indices) + allocate(field_global_offset(n_fields+1), nest_op%field_map(n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + field_global_offset(1) = 0 + do i_field = 1, n_fields + field_global_offset(i_field+1) = field_global_offset(i_field) & + & + desc_grid%descs(1,i_field)%get_global_rows() + end do + + owned_offset = 0 ! running owned-local offset in the global local vector + do i_field = 1, n_fields + n_owned = desc_grid%descs(1,i_field)%get_local_rows() + n_local = desc_grid%descs(1,i_field)%get_local_cols() + n_ghost = n_local - n_owned + nest_op%field_map(i_field)%n_owned = n_owned + allocate(nest_op%field_map(i_field)%global_local_pos(n_local), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! owned entries: contiguous in the global local vector + do i_entry = 1, n_owned + nest_op%field_map(i_field)%global_local_pos(i_entry) = owned_offset + i_entry + end do + ! ghost entries: locate the field's ghost global index in the global descriptor + do i_entry = 1, n_ghost + call desc_grid%descs(1,i_field)%l2g(n_owned + i_entry, global_idx, info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='l2g'); return + end if + call desc_global%g2l(field_global_offset(i_field) + global_idx, local_pos, info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='g2l'); return + end if + nest_op%field_map(i_field)%global_local_pos(n_owned + i_entry) = local_pos + end do + ! encapsulated copy of the positions for the device-capable gth/sct + allocate(nest_op%field_map(i_field)%gather_pos, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call nest_op%field_map(i_field)%gather_pos%bld(nest_op%field_map(i_field)%global_local_pos) + owned_offset = owned_offset + n_owned + end do + + call nest_op%set_nrows(desc_global%get_local_rows()) + call nest_op%set_ncols(desc_global%get_local_cols()) + call nest_op%set_asb() + + end subroutine psb_c_nest_base_setup + + ! Local block matrix-vector product: y = alpha * A_nest * x + beta * y. + ! x is in the global local layout (owned fields concatenated + global halo); + ! y holds the owned entries (global local rows). + subroutine psb_c_nest_base_csmv(alpha, a, x, beta, y, info, trans) + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + class(psb_c_nest_base_mat), intent(in) :: a + complex(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + complex(psb_spk_), allocatable :: x_field(:), y_field(:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field + character :: trans_op + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_base_csmv' + trans_op = 'N' + if (present(trans)) trans_op = trans + if (trans_op /= 'N' .and. trans_op /= 'n') then + ! transposed product: the block structure of A^T is the transpose of the + ! block grid, handled by the dedicated kernel below ('T' or 'C') + call psb_c_nest_base_csmv_t(alpha, a, x, beta, y, info, trans_op) + return + end if + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + ! y <- beta * y + if (beta == czero) then + y(:) = czero + else if (beta /= cone) then + y(:) = beta * y(:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(x_field(n_local_col_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! gather the column-field input sub-vector (owned + that field's ghosts) + do i_entry = 1, n_local_col_field + x_field(i_entry) = x(a%field_map(j_block_col)%global_local_pos(i_entry)) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(y_field(n_owned_row_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! current row-field output sub-vector (owned) + do i_entry = 1, n_owned_row_field + y_field(i_entry) = y(a%field_map(i_block_row)%global_local_pos(i_entry)) + end do + ! y_field <- alpha * A(i_block_row, j_block_col) * x_field + y_field + call a%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, cone, y_field, info, trans_op) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv') + return + end if + ! scatter the row-field output sub-vector back into y + do i_entry = 1, n_owned_row_field + y(a%field_map(i_block_row)%global_local_pos(i_entry)) = y_field(i_entry) + end do + deallocate(y_field) + end if + end do + deallocate(x_field) + end do + + end subroutine psb_c_nest_base_csmv + + ! Transposed matvec kernel: y = alpha * A^T * x + beta * y. + ! The block structure of A^T is the transpose of the block grid: + ! y(cols of field j) += alpha * sum_i A(i,j)^T * x(owned rows of field i). + ! x is read on the owned rows of each row field; the result lands on ALL the + ! local columns of each column field (owned + ghosts); the distributed caller + ! (psb_spmm with trans='T') then accumulates the ghost contributions to their + ! owners through the transposed halo exchange. + subroutine psb_c_nest_base_csmv_t(alpha, a, x, beta, y, info, trans) + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + class(psb_c_nest_base_mat), intent(in) :: a + complex(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + complex(psb_spk_), allocatable :: x_field(:), y_field(:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_base_csmv_t' + + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + ! y <- beta * y (on the whole column space) + if (beta == czero) then + y(:) = czero + else if (beta /= cone) then + y(:) = beta * y(:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(y_field(n_local_col_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! current column-field output sub-vector (owned + ghosts) + do i_entry = 1, n_local_col_field + y_field(i_entry) = y(a%field_map(j_block_col)%global_local_pos(i_entry)) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(x_field(n_owned_row_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! gather the row-field input sub-vector (owned rows only) + do i_entry = 1, n_owned_row_field + x_field(i_entry) = x(a%field_map(i_block_row)%global_local_pos(i_entry)) + end do + ! y_field <- alpha * A(i,j)^T (or ^H) * x_field + y_field + call a%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, cone, y_field, info, trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv T') + return + end if + deallocate(x_field) + end if + end do + + ! scatter the column-field output sub-vector back into y + do i_entry = 1, n_local_col_field + y(a%field_map(j_block_col)%global_local_pos(i_entry)) = y_field(i_entry) + end do + deallocate(y_field) + end do + end subroutine psb_c_nest_base_csmv_t + + ! csmm: multi-RHS product, the 2D analogue of csmv (same gather/scatter + ! per field, the block product is the block's own csmm) + subroutine psb_c_nest_base_csmm(alpha, a, x, beta, y, info, trans) + class(psb_c_nest_base_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + complex(psb_spk_), allocatable :: x_field(:,:), y_field(:,:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field, n_rhs + character :: trans_op + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_base_csmm' + trans_op = 'N' + if (present(trans)) trans_op = trans + if (trans_op /= 'N' .and. trans_op /= 'n') then + info = psb_err_transpose_not_n_unsupported_ + call psb_errpush(info, name); return + end if + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + n_rhs = min(size(x,2), size(y,2)) + + if (beta == czero) then + y(:,:) = czero + else if (beta /= cone) then + y(:,:) = beta * y(:,:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(x_field(n_local_col_field, n_rhs), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do i_entry = 1, n_local_col_field + x_field(i_entry, 1:n_rhs) = x(a%field_map(j_block_col)%global_local_pos(i_entry), 1:n_rhs) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(y_field(n_owned_row_field, n_rhs), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do i_entry = 1, n_owned_row_field + y_field(i_entry, 1:n_rhs) = y(a%field_map(i_block_row)%global_local_pos(i_entry), 1:n_rhs) + end do + call a%block_storage%mats(i_block_row, j_block_col)%a%csmm( & + & alpha, x_field, cone, y_field, info, trans_op) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmm') + return + end if + do i_entry = 1, n_owned_row_field + y(a%field_map(i_block_row)%global_local_pos(i_entry), 1:n_rhs) = y_field(i_entry, 1:n_rhs) + end do + deallocate(y_field) + end if + end do + deallocate(x_field) + end do + end subroutine psb_c_nest_base_csmm + + ! cp_to_coo: assemble all the blocks into a single local COO in the + ! global-local layout (rows = concatenated owned rows, columns = the + ! operator's column space). This is the core conversion hook: the generic + ! base-class machinery builds cscnv, csclip, tril/triu, ... on top of it. + subroutine psb_c_nest_base_cp_to_coo(a, b, info) + use psb_c_base_mat_mod, only : psb_c_coo_sparse_mat + class(psb_c_nest_base_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_c_coo_sparse_mat) :: block_coo + integer(psb_ipk_) :: i_field, j_field, k_entry, n_entries, out_pos, owned_offset + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_cp_to_coo' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + call b%allocate(a%get_nrows(), a%get_ncols(), a%get_nzeros()) + out_pos = 0 + owned_offset = 0 + do i_field = 1, a%n_fields + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%cp_to_coo(block_coo, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block cp_to_coo') + return + end if + n_entries = block_coo%get_nzeros() + do k_entry = 1, n_entries + b%ia(out_pos+k_entry) = owned_offset + block_coo%ia(k_entry) + b%ja(out_pos+k_entry) = a%field_map(j_field)%global_local_pos(block_coo%ja(k_entry)) + b%val(out_pos+k_entry) = block_coo%val(k_entry) + end do + out_pos = out_pos + n_entries + call block_coo%free() + end do + owned_offset = owned_offset + a%field_map(i_field)%n_owned + end do + call b%set_nzeros(out_pos) + call b%set_dupl(psb_dupl_add_) + call b%fix(info) + if (info /= psb_success_) & + & call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix') + end subroutine psb_c_nest_base_cp_to_coo + + ! mv_to_coo: the adapter does not own the blocks, so "move" degenerates to + ! copy + detach of the adapter + subroutine psb_c_nest_base_mv_to_coo(a, b, info) + use psb_c_base_mat_mod, only : psb_c_coo_sparse_mat + class(psb_c_nest_base_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + call a%cp_to_coo(b, info) + if (info == psb_success_) call a%free() + end subroutine psb_c_nest_base_mv_to_coo + + ! rowsum: row sums (matrix-valued type), accumulated across the blocks of + ! each row field; d is in the global-local row layout + subroutine psb_c_nest_base_rowsum(d, a) + class(psb_c_nest_base_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + complex(psb_spk_), allocatable :: block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset + + d(:) = czero + if (.not. associated(a%block_storage)) return + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + allocate(block_sums(n_owned)) + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%rowsum(block_sums) + do k_entry = 1, n_owned + d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) + end do + end do + deallocate(block_sums) + owned_offset = owned_offset + n_owned + end do + end subroutine psb_c_nest_base_rowsum + + ! arwsum: absolute row sums (always real-valued) + subroutine psb_c_nest_base_arwsum(d, a) + class(psb_c_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + real(psb_spk_), allocatable :: block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset + + d(:) = szero + if (.not. associated(a%block_storage)) return + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + allocate(block_sums(n_owned)) + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%arwsum(block_sums) + do k_entry = 1, n_owned + d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) + end do + end do + deallocate(block_sums) + owned_offset = owned_offset + n_owned + end do + end subroutine psb_c_nest_base_arwsum + + ! colsum: column sums (matrix-valued type) in the operator's column space, + ! accumulated across the blocks of each column field + subroutine psb_c_nest_base_colsum(d, a) + class(psb_c_nest_base_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + complex(psb_spk_), allocatable :: field_sums(:), block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_local + + d(:) = czero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(field_sums(n_local), block_sums(n_local)) + field_sums(:) = czero + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%colsum(block_sums) + field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) + end do + do k_entry = 1, n_local + d(a%field_map(j_field)%global_local_pos(k_entry)) = field_sums(k_entry) + end do + deallocate(field_sums, block_sums) + end do + end subroutine psb_c_nest_base_colsum + + ! aclsum: absolute column sums (always real-valued) + subroutine psb_c_nest_base_aclsum(d, a) + class(psb_c_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + real(psb_spk_), allocatable :: field_sums(:), block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_local + + d(:) = szero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(field_sums(n_local), block_sums(n_local)) + field_sums(:) = szero + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%aclsum(block_sums) + field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) + end do + do k_entry = 1, n_local + d(a%field_map(j_field)%global_local_pos(k_entry)) = field_sums(k_entry) + end do + deallocate(field_sums, block_sums) + end do + end subroutine psb_c_nest_base_aclsum + + ! maxval / infinity norm / 1-norm, by delegation/accumulation over blocks + function psb_c_nest_base_maxval(a) result(res) + class(psb_c_nest_base_mat), intent(in) :: a + real(psb_spk_) :: res + integer(psb_ipk_) :: i_field, j_field + res = szero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + do i_field = 1, a%n_fields + if (a%block_storage%has_block(i_field, j_field)) & + & res = max(res, a%block_storage%mats(i_field,j_field)%a%maxval()) + end do + end do + end function psb_c_nest_base_maxval + + function psb_c_nest_base_csnmi(a) result(res) + class(psb_c_nest_base_mat), intent(in) :: a + real(psb_spk_) :: res + real(psb_spk_), allocatable :: row_sums(:) + res = szero + if (a%get_nrows() <= 0) return + allocate(row_sums(a%get_nrows())) + call psb_c_nest_base_arwsum(row_sums, a) + res = maxval(row_sums) + end function psb_c_nest_base_csnmi + + function psb_c_nest_base_csnm1(a) result(res) + class(psb_c_nest_base_mat), intent(in) :: a + real(psb_spk_) :: res + real(psb_spk_), allocatable :: col_sums(:) + res = szero + if (a%get_ncols() <= 0) return + allocate(col_sums(a%get_ncols())) + call psb_c_nest_base_aclsum(col_sums, a) + res = maxval(col_sums) + end function psb_c_nest_base_csnm1 + + ! scals/scal: scaling acts on the underlying blocks (the operator is a view) + subroutine psb_c_nest_base_scals(d, a, info) + class(psb_c_nest_base_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field, j_field + character(len=24) :: name + info = psb_success_ + name = 'psb_c_nest_scals' + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_mat_state_; call psb_errpush(info, name); return + end if + do j_field = 1, a%n_fields + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal(d, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal'); return + end if + end do + end do + end subroutine psb_c_nest_base_scals + + subroutine psb_c_nest_base_scal(d, a, info, side) + class(psb_c_nest_base_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + complex(psb_spk_), allocatable :: d_field(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, n_local, owned_offset + character :: side_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_scal' + side_ = 'L' + if (present(side)) side_ = side + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_mat_state_; call psb_errpush(info, name); return + end if + + if (side_ == 'L' .or. side_ == 'l') then + ! row scaling: each row field uses its owned slice of d + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal( & + & d(owned_offset+1:owned_offset+n_owned), info, side='L') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal L'); return + end if + end do + owned_offset = owned_offset + n_owned + end do + else + ! column scaling: each column field gathers its slice of d + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(d_field(n_local)) + do k_entry = 1, n_local + d_field(k_entry) = d(a%field_map(j_field)%global_local_pos(k_entry)) + end do + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal(d_field, info, side='R') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal R'); return + end if + end do + deallocate(d_field) + end do + end if + end subroutine psb_c_nest_base_scal + + ! clone: the adapter is a view, so the clone shares the blocks and the grid + ! descriptor (pointers) while re-owning its private gather index vectors + subroutine psb_c_nest_base_clone(a, b, info) + class(psb_c_nest_base_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field + + info = psb_success_ + if (allocated(b)) deallocate(b) + allocate(b, source=a, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_c_nest_clone'); return + end if + select type (b_nest => b) + type is (psb_c_nest_base_mat) + if (allocated(b_nest%field_map)) then + do i_field = 1, size(b_nest%field_map) + ! the sourced copy shares a's gather_pos targets: re-own fresh copies + b_nest%field_map(i_field)%gather_pos => null() + allocate(b_nest%field_map(i_field)%gather_pos, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_c_nest_clone'); return + end if + call b_nest%field_map(i_field)%gather_pos%bld( & + & b_nest%field_map(i_field)%global_local_pos) + end do + end if + end select + end subroutine psb_c_nest_base_clone + + subroutine psb_c_nest_base_mold(a, b, info) + class(psb_c_nest_base_mat), intent(in) :: a + class(psb_c_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + if (allocated(b)) deallocate(b) + allocate(b, mold=a, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_c_nest_mold') + end if + end subroutine psb_c_nest_base_mold + + ! sizeof: blocks + gather maps (the adapter does not own the descriptors) + function psb_c_nest_base_sizeof(a) result(res) + class(psb_c_nest_base_mat), intent(in) :: a + integer(psb_epk_) :: res + integer(psb_ipk_) :: i_field + res = 8 + if (associated(a%block_storage)) res = res + a%block_storage%sizeof() + if (allocated(a%field_map)) then + do i_field = 1, size(a%field_map) + if (allocated(a%field_map(i_field)%global_local_pos)) & + & res = res + psb_sizeof_ip * size(a%field_map(i_field)%global_local_pos) + end do + end if + end function psb_c_nest_base_sizeof + + ! Selective (regime 2) application of a SINGLE block: + ! y_field = alpha * A(i_block_row, j_block_col) * x_field + beta * y_field + ! x_field is the column-field local vector (owned + ghosts) ALREADY halo-exchanged + ! by the caller; y_field is the row-field owned local vector. The caller chooses + ! the exchange regime (the union halo, or just this block's halo), so this + ! routine is purely local. It is FORMAT-AGNOSTIC: it dispatches to the block's + ! own polymorphic csmv, so the block may be CSR, COO, ... independently of the + ! other blocks. (The full-operator matvec, regime 1, is psb_c_nest_base_csmv.) + subroutine psb_c_nest_apply_block(nest_op, i_block_row, j_block_col, alpha, x_field, beta, y_field, info) + type(psb_c_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + complex(psb_spk_), intent(in) :: alpha, beta, x_field(:) + complex(psb_spk_), intent(inout) :: y_field(:) + integer(psb_ipk_), intent(out) :: info + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_apply_block' + + if (.not. associated(nest_op%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (.not. nest_op%block_storage%has_block(i_block_row, j_block_col)) then + ! absent block contributes zero: y_field <- beta * y_field + if (beta == czero) then + y_field(:) = czero + else if (beta /= cone) then + y_field(:) = beta * y_field(:) + end if + return + end if + + ! polymorphic dispatch: the block applies its own format (CSR/COO/...) + call nest_op%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, beta, y_field, info) + if (info /= psb_success_) & + & call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv') + + end subroutine psb_c_nest_apply_block + + ! ==================================================================== + ! Field-split interface (for the block preconditioner). + ! Exposes the field structure so a fieldsplit/Schur preconditioner can: + ! - know how many fields there are and their owned sizes; + ! - get a block as a standard psb_cspmat_type (sub-preconditioner on A, + ! Schur-complement matvecs with B / B^T); + ! - get a field descriptor (run a field-level Krylov / halo exchange); + ! - restrict the global vector to a field sub-vector and prolong it back. + ! ==================================================================== + + function psb_c_nest_get_n_fields(nest_op) result(n_fields) + type(psb_c_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_) :: n_fields + n_fields = nest_op%n_fields + end function psb_c_nest_get_n_fields + + function psb_c_nest_get_field_owned(nest_op, field) result(n_owned) + type(psb_c_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + integer(psb_ipk_) :: n_owned + n_owned = 0 + if (allocated(nest_op%field_map) .and. field >= 1 .and. field <= nest_op%n_fields) & + & n_owned = nest_op%field_map(field)%n_owned + end function psb_c_nest_get_field_owned + + ! Pointer to block (i,j) as a standard psb_cspmat_type (null if absent). + function psb_c_nest_get_block(nest_op, i_block_row, j_block_col) result(block_ptr) + type(psb_c_nest_base_mat), target, intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + type(psb_cspmat_type), pointer :: block_ptr + block_ptr => null() + if (associated(nest_op%block_storage)) then + if (nest_op%block_storage%has_block(i_block_row, j_block_col)) & + & block_ptr => nest_op%block_storage%mats(i_block_row, j_block_col) + end if + end function psb_c_nest_get_block + + ! Pointer to field k's descriptor (null if not set up). + function psb_c_nest_get_field_desc(nest_op, field) result(desc_ptr) + type(psb_c_nest_base_mat), target, intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + type(psb_desc_type), pointer :: desc_ptr + desc_ptr => null() + if (associated(nest_op%grid_desc) .and. field >= 1 .and. field <= nest_op%n_fields) & + & desc_ptr => nest_op%grid_desc%descs(1, field) + end function psb_c_nest_get_field_desc + + ! Restrict: extract field k's OWNED sub-vector from the global local vector. + subroutine psb_c_nest_restrict_field(nest_op, field, x_global, x_field, info) + type(psb_c_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + complex(psb_spk_), intent(in) :: x_global(:) + complex(psb_spk_), intent(out) :: x_field(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_entry, n_owned + info = psb_success_ + if (field < 1 .or. field > nest_op%n_fields) then + info = psb_err_invalid_input_; return + end if + n_owned = nest_op%field_map(field)%n_owned + do i_entry = 1, n_owned + x_field(i_entry) = x_global(nest_op%field_map(field)%global_local_pos(i_entry)) + end do + end subroutine psb_c_nest_restrict_field + + ! Prolong: insert field k's OWNED sub-vector into the global local vector. + subroutine psb_c_nest_prolong_field(nest_op, field, x_field, x_global, info) + type(psb_c_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + complex(psb_spk_), intent(in) :: x_field(:) + complex(psb_spk_), intent(inout) :: x_global(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_entry, n_owned + info = psb_success_ + if (field < 1 .or. field > nest_op%n_fields) then + info = psb_err_invalid_input_; return + end if + n_owned = nest_op%field_map(field)%n_owned + do i_entry = 1, n_owned + x_global(nest_op%field_map(field)%global_local_pos(i_entry)) = x_field(i_entry) + end do + end subroutine psb_c_nest_prolong_field + +end module psb_c_nest_base_mat_mod diff --git a/base/modules/serial/psb_c_nest_mat_mod.f90 b/base/modules/serial/psb_c_nest_mat_mod.f90 new file mode 100644 index 000000000..05c617de5 --- /dev/null +++ b/base/modules/serial/psb_c_nest_mat_mod.f90 @@ -0,0 +1,149 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific without permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! module: psb_c_nest_mat_mod +! Author: Simone Staccone (Stack-1) +! +! Defines psb_c_nest_sparse_mat: a block-structured distributed sparse +! matrix for double precision real arithmetic. +! +! The matrix is stored as a 2-D array of psb_cspmat_type sub-matrices. +! Block presence is determined directly from the sub-matrix storage: a block +! (i,j) is present iff mats(i,j)%a is allocated (absent blocks contribute zero +! to any product). There is no separate presence flag array. +! +! Descriptor convention (current nested design) +! --------------------------------------------- +! Each matrix block (i,j) is associated with descs(i,j) from the +! corresponding psb_desc_nest_type. Nested tools (psb_spall_nest, +! psb_spins_nest, psb_spasb_nest, psb_spmm) consistently pass +! descs(i,j) together with mats(i,j). +! +! A block may be structurally absent (NULL/zero): this is represented by +! mats(i,j) left unbuilt (mats(i,j)%a not allocated). In that case the +! block contributes zero and is skipped by nested kernels. +! +! Descriptor storage is distinct from matrix presence: descriptors are +! typically defined for all block positions in descs(:,:), while actual +! matrix blocks may be present only on a subset. +! +! Reference examples in test/pdegen: +! * psb_c_pde_nest.full.F90 (A(2,2) left NULL, mats(2,2)%a not allocated) +! * psb_c_nest_tools.F90 and psb_c_pde_nest_full_tools.F90 +! (2-D desc_nest%descs(i,j) used in nested allocation/assembly). +! +module psb_c_nest_mat_mod + use psb_c_mat_mod + implicit none + + type :: psb_c_nest_sparse_mat + integer(psb_ipk_) :: nrblocks = 0 + integer(psb_ipk_) :: ncblocks = 0 + type(psb_cspmat_type), allocatable :: mats(:,:) + contains + procedure :: get_nrblocks => psb_c_nest_mat_get_nrb + procedure :: get_ncblocks => psb_c_nest_mat_get_ncb + procedure :: has_block => psb_c_nest_mat_has_block + procedure :: sizeof => psb_c_nest_mat_sizeof + procedure :: free => psb_c_nest_mat_free + end type psb_c_nest_sparse_mat + +contains + + ! get_nrblocks / get_ncblocks + function psb_c_nest_mat_get_nrb(a) result(n) + class(psb_c_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: n + n = a%nrblocks + end function psb_c_nest_mat_get_nrb + + function psb_c_nest_mat_get_ncb(a) result(n) + class(psb_c_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: n + n = a%ncblocks + end function psb_c_nest_mat_get_ncb + + ! has_block: return .true. if block (i,j) is non-null + function psb_c_nest_mat_has_block(a, i_block_row, j_block_col) result(has) + class(psb_c_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + logical :: has + + has = .false. + if (i_block_row < 1 .or. i_block_row > a%nrblocks) return + if (j_block_col < 1 .or. j_block_col > a%ncblocks) return + if (.not. allocated(a%mats)) return + ! P3: presence is determined solely by whether the sub-matrix has been + ! built (its polymorphic storage %a is allocated). No parallel flag array. + has = allocated(a%mats(i_block_row, j_block_col)%a) + end function psb_c_nest_mat_has_block + + ! sizeof: total storage across all allocated sub-matrices + function psb_c_nest_mat_sizeof(a) result(total_bytes) + class(psb_c_nest_sparse_mat), intent(in) :: a + integer(psb_epk_) :: total_bytes + integer(psb_ipk_) :: i_block_row, j_block_col + + total_bytes = 0_psb_epk_ + if (allocated(a%mats)) then + do j_block_col = 1, a%ncblocks + do i_block_row = 1, a%nrblocks + if (allocated(a%mats(i_block_row, j_block_col)%a)) & + & total_bytes = total_bytes + a%mats(i_block_row, j_block_col)%sizeof() + end do + end do + end if + end function psb_c_nest_mat_sizeof + + ! free: release all sub-matrices + subroutine psb_c_nest_mat_free(a, info) + class(psb_c_nest_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + + info = 0 + if (allocated(a%mats)) then + do j_block_col = 1, a%ncblocks + do i_block_row = 1, a%nrblocks + if (allocated(a%mats(i_block_row, j_block_col)%a)) then + call a%mats(i_block_row, j_block_col)%free() + end if + end do + end do + deallocate(a%mats, stat=local_info) + if (local_info /= 0 .and. info == 0) info = local_info + end if + a%nrblocks = 0 + a%ncblocks = 0 + end subroutine psb_c_nest_mat_free + +end module psb_c_nest_mat_mod diff --git a/base/modules/serial/psb_d_nest_base_mat_mod.F90 b/base/modules/serial/psb_d_nest_base_mat_mod.F90 index 5b48288b5..ed97a2521 100644 --- a/base/modules/serial/psb_d_nest_base_mat_mod.F90 +++ b/base/modules/serial/psb_d_nest_base_mat_mod.F90 @@ -362,7 +362,7 @@ contains real(psb_dpk_), allocatable :: x_host(:), y_host(:) x_host = x%get_vect() y_host = y%get_vect() - call psb_d_nest_base_csmv_t(alpha, a, x_host, beta, y_host, info) + call psb_d_nest_base_csmv_t(alpha, a, x_host, beta, y_host, info, trans_) call y%bld(y_host) end block return @@ -536,8 +536,8 @@ contains if (present(trans)) trans_op = trans if (trans_op /= 'N' .and. trans_op /= 'n') then ! transposed product: the block structure of A^T is the transpose of the - ! block grid, handled by the dedicated kernel below - call psb_d_nest_base_csmv_t(alpha, a, x, beta, y, info) + ! block grid, handled by the dedicated kernel below ('T' or 'C') + call psb_d_nest_base_csmv_t(alpha, a, x, beta, y, info, trans_op) return end if if (.not. associated(a%block_storage)) then @@ -601,11 +601,12 @@ contains ! local columns of each column field (owned + ghosts); the distributed caller ! (psb_spmm with trans='T') then accumulates the ghost contributions to their ! owners through the transposed halo exchange. - subroutine psb_d_nest_base_csmv_t(alpha, a, x, beta, y, info) + subroutine psb_d_nest_base_csmv_t(alpha, a, x, beta, y, info, trans) real(psb_dpk_), intent(in) :: alpha, beta, x(:) class(psb_d_nest_base_mat), intent(in) :: a real(psb_dpk_), intent(inout) :: y(:) integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans real(psb_dpk_), allocatable :: x_field(:), y_field(:) integer(psb_ipk_) :: i_block_row, j_block_col, i_entry @@ -650,9 +651,9 @@ contains do i_entry = 1, n_owned_row_field x_field(i_entry) = x(a%field_map(i_block_row)%global_local_pos(i_entry)) end do - ! y_field <- alpha * A(i,j)^T * x_field + y_field + ! y_field <- alpha * A(i,j)^T (or ^H) * x_field + y_field call a%block_storage%mats(i_block_row, j_block_col)%a%csmv( & - & alpha, x_field, done, y_field, info, 'T') + & alpha, x_field, done, y_field, info, trans) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv T') return @@ -805,24 +806,37 @@ contains if (info == psb_success_) call a%free() end subroutine psb_d_nest_base_mv_to_coo - ! rowsum/arwsum: (absolute) row sums, accumulated across the blocks of each - ! row field; d is in the global-local row layout + ! rowsum: row sums (matrix-valued type), accumulated across the blocks of + ! each row field; d is in the global-local row layout subroutine psb_d_nest_base_rowsum(d, a) class(psb_d_nest_base_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - call psb_d_nest_base_sum_rows(d, a, absolute=.false.) + + real(psb_dpk_), allocatable :: block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset + + d(:) = dzero + if (.not. associated(a%block_storage)) return + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + allocate(block_sums(n_owned)) + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%rowsum(block_sums) + do k_entry = 1, n_owned + d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) + end do + end do + deallocate(block_sums) + owned_offset = owned_offset + n_owned + end do end subroutine psb_d_nest_base_rowsum + ! arwsum: absolute row sums (always real-valued) subroutine psb_d_nest_base_arwsum(d, a) class(psb_d_nest_base_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - call psb_d_nest_base_sum_rows(d, a, absolute=.true.) - end subroutine psb_d_nest_base_arwsum - - subroutine psb_d_nest_base_sum_rows(d, a, absolute) - real(psb_dpk_), intent(out) :: d(:) - class(psb_d_nest_base_mat), intent(in) :: a - logical, intent(in) :: absolute real(psb_dpk_), allocatable :: block_sums(:) integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset @@ -835,11 +849,7 @@ contains allocate(block_sums(n_owned)) do j_field = 1, a%n_fields if (.not. a%block_storage%has_block(i_field, j_field)) cycle - if (absolute) then - call a%block_storage%mats(i_field,j_field)%a%arwsum(block_sums) - else - call a%block_storage%mats(i_field,j_field)%a%rowsum(block_sums) - end if + call a%block_storage%mats(i_field,j_field)%a%arwsum(block_sums) do k_entry = 1, n_owned d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) end do @@ -847,26 +857,39 @@ contains deallocate(block_sums) owned_offset = owned_offset + n_owned end do - end subroutine psb_d_nest_base_sum_rows + end subroutine psb_d_nest_base_arwsum - ! colsum/aclsum: (absolute) column sums in the operator's column space, + ! colsum: column sums (matrix-valued type) in the operator's column space, ! accumulated across the blocks of each column field subroutine psb_d_nest_base_colsum(d, a) class(psb_d_nest_base_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - call psb_d_nest_base_sum_cols(d, a, absolute=.false.) + + real(psb_dpk_), allocatable :: field_sums(:), block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_local + + d(:) = dzero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(field_sums(n_local), block_sums(n_local)) + field_sums(:) = dzero + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%colsum(block_sums) + field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) + end do + do k_entry = 1, n_local + d(a%field_map(j_field)%global_local_pos(k_entry)) = field_sums(k_entry) + end do + deallocate(field_sums, block_sums) + end do end subroutine psb_d_nest_base_colsum + ! aclsum: absolute column sums (always real-valued) subroutine psb_d_nest_base_aclsum(d, a) class(psb_d_nest_base_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - call psb_d_nest_base_sum_cols(d, a, absolute=.true.) - end subroutine psb_d_nest_base_aclsum - - subroutine psb_d_nest_base_sum_cols(d, a, absolute) - real(psb_dpk_), intent(out) :: d(:) - class(psb_d_nest_base_mat), intent(in) :: a - logical, intent(in) :: absolute real(psb_dpk_), allocatable :: field_sums(:), block_sums(:) integer(psb_ipk_) :: i_field, j_field, k_entry, n_local @@ -879,11 +902,7 @@ contains field_sums(:) = dzero do i_field = 1, a%n_fields if (.not. a%block_storage%has_block(i_field, j_field)) cycle - if (absolute) then - call a%block_storage%mats(i_field,j_field)%a%aclsum(block_sums) - else - call a%block_storage%mats(i_field,j_field)%a%colsum(block_sums) - end if + call a%block_storage%mats(i_field,j_field)%a%aclsum(block_sums) field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) end do do k_entry = 1, n_local @@ -891,7 +910,7 @@ contains end do deallocate(field_sums, block_sums) end do - end subroutine psb_d_nest_base_sum_cols + end subroutine psb_d_nest_base_aclsum ! maxval / infinity norm / 1-norm, by delegation/accumulation over blocks function psb_d_nest_base_maxval(a) result(res) @@ -915,7 +934,7 @@ contains res = dzero if (a%get_nrows() <= 0) return allocate(row_sums(a%get_nrows())) - call psb_d_nest_base_sum_rows(row_sums, a, absolute=.true.) + call psb_d_nest_base_arwsum(row_sums, a) res = maxval(row_sums) end function psb_d_nest_base_csnmi @@ -926,7 +945,7 @@ contains res = dzero if (a%get_ncols() <= 0) return allocate(col_sums(a%get_ncols())) - call psb_d_nest_base_sum_cols(col_sums, a, absolute=.true.) + call psb_d_nest_base_aclsum(col_sums, a) res = maxval(col_sums) end function psb_d_nest_base_csnm1 diff --git a/base/modules/serial/psb_s_nest_base_mat_mod.F90 b/base/modules/serial/psb_s_nest_base_mat_mod.F90 new file mode 100644 index 000000000..37dcd1dc4 --- /dev/null +++ b/base/modules/serial/psb_s_nest_base_mat_mod.F90 @@ -0,0 +1,1212 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_s_nest_base_mat_mod.F90 +! +! Module: psb_s_nest_base_mat_mod +! Author: Simone Staccone (Stack-1) +! +! Adapter that makes a block-structured (nested) operator look like a standard +! local sparse matrix to PSBLAS: psb_s_nest_base_mat EXTENDS +! psb_s_base_sparse_mat and implements csmv (the local matrix-vector product). +! Wrapped in a psb_sspmat_type and paired with the composed global descriptor +! (see psb_cd_nest_compose), the nested operator can then be fed to psb_spmm, +! psb_krylov and the AMG4PSBLAS preconditioners unchanged (MATNEST-style). +! +! The local vector handed to csmv lives in the GLOBAL local layout produced by +! psb_cd_nest_compose: the owned entries of all fields are concatenated, followed +! by the global halo. For each field we precompute field_map(field)%global_local_pos, +! the positions in that global local vector of the field's own local vector +! (owned entries first, then the field's ghosts), so we can gather the field +! input sub-vector and scatter the field output sub-vector without further +! communication (the halo exchange is done once by psb_spmm on the global desc). +! +module psb_s_nest_base_mat_mod + use psb_const_mod + use psb_error_mod + use psb_realloc_mod, only : psb_ensure_size + use psb_s_base_mat_mod, only : psb_s_base_sparse_mat + use psb_s_base_vect_mod, only : psb_s_base_vect_type + use psb_i_vect_mod, only : psb_i_vect_type + use psb_desc_mod, only : psb_desc_type + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_s_nest_mat_mod, only : psb_s_nest_sparse_mat + use psb_s_mat_mod, only : psb_sspmat_type + implicit none + + ! Per-field gather/scatter map into the global local vector. + ! global_local_pos(1 : n_owned) -> the field's owned entries + ! global_local_pos(n_owned+1 : size) -> the field's ghost (halo) entries + type :: psb_s_nest_field_map + integer(psb_ipk_) :: n_owned = 0 + integer(psb_ipk_), allocatable :: global_local_pos(:) + ! same positions as an encapsulated index vector, for the device-capable + ! gather/scatter (gth/sct) used by vect_mv; pointer so that its target can + ! be synced even when the operator dummy argument is intent(in) + type(psb_i_vect_type), pointer :: gather_pos => null() + end type psb_s_nest_field_map + + type, extends(psb_s_base_sparse_mat) :: psb_s_nest_base_mat + integer(psb_ipk_) :: n_fields = 0 + type(psb_s_nest_sparse_mat), pointer :: block_storage => null() ! blocks (not owned) + type(psb_desc_nest_type), pointer :: grid_desc => null() ! per-field descriptors (not owned) + type(psb_s_nest_field_map), allocatable :: field_map(:) + contains + procedure, pass(a) :: csmv => psb_s_nest_base_csmv + procedure, pass(a) :: get_nzeros => psb_s_nest_base_get_nzeros + procedure, nopass :: get_fmt => psb_s_nest_base_get_fmt + procedure, pass(a) :: free => psb_s_nest_base_free + ! enable the stock PSBLAS preconditioners on the nested operator: + ! get_diag is used by DIAG/JACOBI, csgetrow by BJAC (ILU factorizations + ! go through the format-agnostic csget path) + procedure, pass(a) :: get_diag => psb_s_nest_base_get_diag + procedure, pass(a) :: csgetrow => psb_s_nest_base_csgetrow + ! device-capable matvec on encapsulated vectors: gathers/scatters through + ! the vectors' own gth/sct and runs each block through its vect_mv, so + ! device block formats execute their device kernels + procedure, pass(a) :: vect_mv => psb_s_nest_base_vect_mv + ! full base-class contract (delegating to the blocks): + procedure, pass(a) :: csmm => psb_s_nest_base_csmm + procedure, pass(a) :: cp_to_coo => psb_s_nest_base_cp_to_coo + procedure, pass(a) :: mv_to_coo => psb_s_nest_base_mv_to_coo + procedure, pass(a) :: rowsum => psb_s_nest_base_rowsum + procedure, pass(a) :: arwsum => psb_s_nest_base_arwsum + procedure, pass(a) :: colsum => psb_s_nest_base_colsum + procedure, pass(a) :: aclsum => psb_s_nest_base_aclsum + procedure, pass(a) :: maxval => psb_s_nest_base_maxval + procedure, pass(a) :: spnmi => psb_s_nest_base_csnmi + procedure, pass(a) :: spnm1 => psb_s_nest_base_csnm1 + procedure, pass(a) :: scals => psb_s_nest_base_scals + procedure, pass(a) :: scalv => psb_s_nest_base_scal + procedure, pass(a) :: clone => psb_s_nest_base_clone + procedure, pass(a) :: mold => psb_s_nest_base_mold + procedure, pass(a) :: sizeof => psb_s_nest_base_sizeof + ! NOT implemented on purpose (base error 700 is the intended behaviour): + ! cp_from_coo / mv_from_coo (a nested operator cannot be built from a flat + ! matrix without the field structure), csput (insertions go to the blocks + ! before assembly), cssv/cssm (triangular solve is undefined for a block + ! operator) + end type psb_s_nest_base_mat + + private + public :: psb_s_nest_base_mat, psb_s_nest_base_setup, psb_s_nest_apply_block + ! field-split interface (for the block preconditioner) + public :: psb_s_nest_get_n_fields, psb_s_nest_get_field_owned, & + & psb_s_nest_get_block, psb_s_nest_get_field_desc, & + & psb_s_nest_restrict_field, psb_s_nest_prolong_field + +contains + + function psb_s_nest_base_get_fmt() result(format_name) + character(len=5) :: format_name + format_name = 'NEST' + end function psb_s_nest_base_get_fmt + + ! free: the nested operator does NOT own block_storage / grid_desc (they are + ! pointers into the caller), so we only detach them and release the field maps. + subroutine psb_s_nest_base_free(a) + class(psb_s_nest_base_mat), intent(inout) :: a + integer(psb_ipk_) :: i_field, local_info + if (allocated(a%field_map)) then + do i_field = 1, size(a%field_map) + if (associated(a%field_map(i_field)%gather_pos)) then + call a%field_map(i_field)%gather_pos%free(local_info) + deallocate(a%field_map(i_field)%gather_pos) + a%field_map(i_field)%gather_pos => null() + end if + end do + deallocate(a%field_map) + end if + a%block_storage => null() + a%grid_desc => null() + a%n_fields = 0 + call a%set_null() + end subroutine psb_s_nest_base_free + + function psb_s_nest_base_get_nzeros(a) result(total_nzeros) + class(psb_s_nest_base_mat), intent(in) :: a + integer(psb_ipk_) :: total_nzeros + integer(psb_ipk_) :: i_block_row, j_block_col + total_nzeros = 0 + if (associated(a%block_storage)) then + do j_block_col = 1, a%block_storage%ncblocks + do i_block_row = 1, a%block_storage%nrblocks + if (a%block_storage%has_block(i_block_row, j_block_col)) & + & total_nzeros = total_nzeros + & + & a%block_storage%mats(i_block_row, j_block_col)%get_nzeros() + end do + end do + end if + end function psb_s_nest_base_get_nzeros + + ! get_diag: diagonal of the global operator. In the global-local layout the + ! owned entries of field i occupy positions owned_offset+1..owned_offset+n_owned, + ! and for owned indices the field-local column k maps to the same global-local + ! position as row k, so the global diagonal is the concatenation of the + ! diagonals of the diagonal blocks (i,i); absent blocks contribute zeros + ! (e.g. the (2,2) block of a saddle-point operator). + subroutine psb_s_nest_base_get_diag(a, d, info) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + real(psb_spk_), allocatable :: block_diag(:) + integer(psb_ipk_) :: i_field, n_owned, owned_offset + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_get_diag' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (size(d) < a%get_nrows()) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='d too small') + return + end if + + d(1:a%get_nrows()) = szero + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + if (a%block_storage%has_block(i_field, i_field)) then + allocate(block_diag(n_owned), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call a%block_storage%mats(i_field,i_field)%a%get_diag(block_diag, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block get_diag') + return + end if + d(owned_offset+1 : owned_offset+n_owned) = block_diag(1:n_owned) + deallocate(block_diag) + end if + owned_offset = owned_offset + n_owned + end do + end subroutine psb_s_nest_base_get_diag + + ! csgetrow: extract local rows imin..imax of the global operator as COO + ! triplets, with columns in the global-local layout (the operator's column + ! space). Each global-local row r belongs to one field i (row k within the + ! field); its entries are the union over j of row k of block (i,j), with the + ! block-local column c remapped through field_map(j)%global_local_pos(c). + ! This is the format-agnostic access path used by the ILU factorizations of + ! the BJAC preconditioner (via csget/csgetblk). + subroutine psb_s_nest_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + class(psb_s_nest_base_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale,chksz + + integer(psb_ipk_), allocatable :: block_row_ia(:), block_row_ja(:) + real(psb_spk_), allocatable :: block_row_val(:) + integer(psb_ipk_) :: jmin_, jmax_, nzin_, out_pos + integer(psb_ipk_) :: r_row, i_field, j_field, k_in_field, owned_offset + integer(psb_ipk_) :: block_nz, t_entry, global_local_col + logical :: append_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_csgetrow' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (present(iren)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='iren not supported'); return + end if + if (present(rscale)) then + if (rscale) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='rscale not supported'); return + end if + end if + if (present(cscale)) then + if (cscale) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='cscale not supported'); return + end if + end if + + jmin_ = 1 + jmax_ = a%get_ncols() + if (present(jmin)) jmin_ = jmin + if (present(jmax)) jmax_ = jmax + append_ = .false. + if (present(append)) append_ = append + nzin_ = 0 + if (append_ .and. present(nzin)) nzin_ = nzin + + nz = 0 + out_pos = nzin_ + + do r_row = max(imin, 1), min(imax, a%get_nrows()) + ! locate the field owning global-local row r_row + owned_offset = 0 + i_field = 0 + do while (i_field < a%n_fields) + i_field = i_field + 1 + if (r_row <= owned_offset + a%field_map(i_field)%n_owned) exit + owned_offset = owned_offset + a%field_map(i_field)%n_owned + end do + k_in_field = r_row - owned_offset + + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%csgetrow(k_in_field, k_in_field, & + & block_nz, block_row_ia, block_row_ja, block_row_val, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csgetrow') + return + end if + do t_entry = 1, block_nz + global_local_col = a%field_map(j_field)%global_local_pos(block_row_ja(t_entry)) + if ((global_local_col < jmin_) .or. (global_local_col > jmax_)) cycle + out_pos = out_pos + 1 + call psb_ensure_size(out_pos, ia, info) + if (info == psb_success_) call psb_ensure_size(out_pos, ja, info) + if (info == psb_success_) call psb_ensure_size(out_pos, val, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ia(out_pos) = r_row + ja(out_pos) = global_local_col + val(out_pos) = block_row_val(t_entry) + nz = nz + 1 + end do + end do + end do + end subroutine psb_s_nest_base_csgetrow + + ! vect_mv: matvec on encapsulated vectors (the path taken by psb_spmm with + ! psb_s_vect_type). Instead of falling back to the host-array csmv, it + ! (1) gathers each column-field sub-vector through the vector's own gth with + ! an encapsulated index vector (a device kernel on device vectors), + ! (2) runs each block through its vect_mv (device formats execute their own + ! device kernels), with per-field work vectors allocated with mold=x so + ! they share the dynamic type of the incoming vectors, + ! (3) scatters each row-field result back through the vector's own sct. + ! Host/device traffic is limited to the compact field buffers; on plain host + ! vectors this is exactly equivalent to the array csmv. + subroutine psb_s_nest_base_vect_mv(alpha, a, x, beta, y, info, trans) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + class(psb_s_base_vect_type), allocatable :: x_field_vec, y_field_vec + real(psb_spk_), allocatable :: x_field_buf(:), y_field_buf(:) + real(psb_spk_) :: block_beta + integer(psb_ipk_) :: i_field, j_field, n_owned, n_local, local_info + logical :: row_has_blocks + character :: trans_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_vect_mv' + + trans_ = 'N' + if (present(trans)) trans_ = trans + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (trans_ /= 'N' .and. trans_ /= 'n') then + ! transposed product: fall back to host arrays (rare path) + block + real(psb_spk_), allocatable :: x_host(:), y_host(:) + x_host = x%get_vect() + y_host = y%get_vect() + call psb_s_nest_base_csmv_t(alpha, a, x_host, beta, y_host, info, trans_) + call y%bld(y_host) + end block + return + end if + + ! work vectors share the dynamic type of the incoming vectors + allocate(x_field_vec, mold=x, stat=info) + if (info == 0) allocate(y_field_vec, mold=y, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + call psb_ensure_size(n_owned, y_field_buf, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + row_has_blocks = .false. + block_beta = szero + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + + ! gather the column-field sub-vector (owned + ghosts) from x + n_local = size(a%field_map(j_field)%global_local_pos) + call psb_ensure_size(n_local, x_field_buf, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call x%gth(ione, int(n_local, psb_mpk_), & + & a%field_map(j_field)%gather_pos%v, x_field_buf) + call x_field_vec%free(local_info) + call x_field_vec%bld(x_field_buf(1:n_local)) + + if (.not. row_has_blocks) then + ! first block of this row field: (re)build the accumulator at the + ! right size, zeroed + y_field_buf(1:n_owned) = szero + call y_field_vec%free(local_info) + call y_field_vec%bld(y_field_buf(1:n_owned)) + row_has_blocks = .true. + end if + + ! y_field = alpha * A(i,j) * x_field + block_beta * y_field + call a%block_storage%mats(i_field,j_field)%a%spmm(alpha, x_field_vec, & + & block_beta, y_field_vec, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block vect_mv') + return + end if + block_beta = sone + end do + + ! scatter the row-field result into y (beta applied on the owned rows); + ! a row field with no blocks still rescales its rows by beta + if (row_has_blocks) then + y_field_buf(1:n_owned) = y_field_vec%get_vect() + else + y_field_buf(1:n_owned) = szero + end if + call y%sct(ione, int(n_owned, psb_mpk_), & + & a%field_map(i_field)%gather_pos%v, y_field_buf, beta) + end do + + call x_field_vec%free(local_info) + call y_field_vec%free(local_info) + end subroutine psb_s_nest_base_vect_mv + + ! Build the per-field gather maps and set the local dimensions, from the nested + ! grid descriptor (per-field distribution desc_grid%descs(1,field)) and the + ! composed global descriptor desc_global (produced by psb_cd_nest_compose). + subroutine psb_s_nest_base_setup(nest_op, block_storage, desc_grid, desc_global, info) + type(psb_s_nest_base_mat), intent(inout) :: nest_op + type(psb_s_nest_sparse_mat), target, intent(in) :: block_storage + type(psb_desc_nest_type), target, intent(in) :: desc_grid + type(psb_desc_type), intent(in) :: desc_global + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_fields, i_field, i_entry + integer(psb_ipk_) :: n_owned, n_local, n_ghost, owned_offset, local_pos + integer(psb_lpk_) :: global_idx + integer(psb_lpk_), allocatable :: field_global_offset(:) + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_base_setup' + + if (desc_grid%nrblocks /= desc_grid%ncblocks) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested block structure must be square') + return + end if + + n_fields = desc_grid%ncblocks + nest_op%n_fields = n_fields + nest_op%grid_desc => desc_grid + nest_op%block_storage => block_storage + + ! global field offsets (used to form ghost global indices) + allocate(field_global_offset(n_fields+1), nest_op%field_map(n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + field_global_offset(1) = 0 + do i_field = 1, n_fields + field_global_offset(i_field+1) = field_global_offset(i_field) & + & + desc_grid%descs(1,i_field)%get_global_rows() + end do + + owned_offset = 0 ! running owned-local offset in the global local vector + do i_field = 1, n_fields + n_owned = desc_grid%descs(1,i_field)%get_local_rows() + n_local = desc_grid%descs(1,i_field)%get_local_cols() + n_ghost = n_local - n_owned + nest_op%field_map(i_field)%n_owned = n_owned + allocate(nest_op%field_map(i_field)%global_local_pos(n_local), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! owned entries: contiguous in the global local vector + do i_entry = 1, n_owned + nest_op%field_map(i_field)%global_local_pos(i_entry) = owned_offset + i_entry + end do + ! ghost entries: locate the field's ghost global index in the global descriptor + do i_entry = 1, n_ghost + call desc_grid%descs(1,i_field)%l2g(n_owned + i_entry, global_idx, info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='l2g'); return + end if + call desc_global%g2l(field_global_offset(i_field) + global_idx, local_pos, info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='g2l'); return + end if + nest_op%field_map(i_field)%global_local_pos(n_owned + i_entry) = local_pos + end do + ! encapsulated copy of the positions for the device-capable gth/sct + allocate(nest_op%field_map(i_field)%gather_pos, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call nest_op%field_map(i_field)%gather_pos%bld(nest_op%field_map(i_field)%global_local_pos) + owned_offset = owned_offset + n_owned + end do + + call nest_op%set_nrows(desc_global%get_local_rows()) + call nest_op%set_ncols(desc_global%get_local_cols()) + call nest_op%set_asb() + + end subroutine psb_s_nest_base_setup + + ! Local block matrix-vector product: y = alpha * A_nest * x + beta * y. + ! x is in the global local layout (owned fields concatenated + global halo); + ! y holds the owned entries (global local rows). + subroutine psb_s_nest_base_csmv(alpha, a, x, beta, y, info, trans) + real(psb_spk_), intent(in) :: alpha, beta, x(:) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + real(psb_spk_), allocatable :: x_field(:), y_field(:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field + character :: trans_op + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_base_csmv' + trans_op = 'N' + if (present(trans)) trans_op = trans + if (trans_op /= 'N' .and. trans_op /= 'n') then + ! transposed product: the block structure of A^T is the transpose of the + ! block grid, handled by the dedicated kernel below ('T' or 'C') + call psb_s_nest_base_csmv_t(alpha, a, x, beta, y, info, trans_op) + return + end if + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + ! y <- beta * y + if (beta == szero) then + y(:) = szero + else if (beta /= sone) then + y(:) = beta * y(:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(x_field(n_local_col_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! gather the column-field input sub-vector (owned + that field's ghosts) + do i_entry = 1, n_local_col_field + x_field(i_entry) = x(a%field_map(j_block_col)%global_local_pos(i_entry)) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(y_field(n_owned_row_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! current row-field output sub-vector (owned) + do i_entry = 1, n_owned_row_field + y_field(i_entry) = y(a%field_map(i_block_row)%global_local_pos(i_entry)) + end do + ! y_field <- alpha * A(i_block_row, j_block_col) * x_field + y_field + call a%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, sone, y_field, info, trans_op) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv') + return + end if + ! scatter the row-field output sub-vector back into y + do i_entry = 1, n_owned_row_field + y(a%field_map(i_block_row)%global_local_pos(i_entry)) = y_field(i_entry) + end do + deallocate(y_field) + end if + end do + deallocate(x_field) + end do + + end subroutine psb_s_nest_base_csmv + + ! Transposed matvec kernel: y = alpha * A^T * x + beta * y. + ! The block structure of A^T is the transpose of the block grid: + ! y(cols of field j) += alpha * sum_i A(i,j)^T * x(owned rows of field i). + ! x is read on the owned rows of each row field; the result lands on ALL the + ! local columns of each column field (owned + ghosts); the distributed caller + ! (psb_spmm with trans='T') then accumulates the ghost contributions to their + ! owners through the transposed halo exchange. + subroutine psb_s_nest_base_csmv_t(alpha, a, x, beta, y, info, trans) + real(psb_spk_), intent(in) :: alpha, beta, x(:) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + real(psb_spk_), allocatable :: x_field(:), y_field(:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_base_csmv_t' + + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + ! y <- beta * y (on the whole column space) + if (beta == szero) then + y(:) = szero + else if (beta /= sone) then + y(:) = beta * y(:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(y_field(n_local_col_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! current column-field output sub-vector (owned + ghosts) + do i_entry = 1, n_local_col_field + y_field(i_entry) = y(a%field_map(j_block_col)%global_local_pos(i_entry)) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(x_field(n_owned_row_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! gather the row-field input sub-vector (owned rows only) + do i_entry = 1, n_owned_row_field + x_field(i_entry) = x(a%field_map(i_block_row)%global_local_pos(i_entry)) + end do + ! y_field <- alpha * A(i,j)^T (or ^H) * x_field + y_field + call a%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, sone, y_field, info, trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv T') + return + end if + deallocate(x_field) + end if + end do + + ! scatter the column-field output sub-vector back into y + do i_entry = 1, n_local_col_field + y(a%field_map(j_block_col)%global_local_pos(i_entry)) = y_field(i_entry) + end do + deallocate(y_field) + end do + end subroutine psb_s_nest_base_csmv_t + + ! csmm: multi-RHS product, the 2D analogue of csmv (same gather/scatter + ! per field, the block product is the block's own csmm) + subroutine psb_s_nest_base_csmm(alpha, a, x, beta, y, info, trans) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + real(psb_spk_), allocatable :: x_field(:,:), y_field(:,:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field, n_rhs + character :: trans_op + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_base_csmm' + trans_op = 'N' + if (present(trans)) trans_op = trans + if (trans_op /= 'N' .and. trans_op /= 'n') then + info = psb_err_transpose_not_n_unsupported_ + call psb_errpush(info, name); return + end if + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + n_rhs = min(size(x,2), size(y,2)) + + if (beta == szero) then + y(:,:) = szero + else if (beta /= sone) then + y(:,:) = beta * y(:,:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(x_field(n_local_col_field, n_rhs), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do i_entry = 1, n_local_col_field + x_field(i_entry, 1:n_rhs) = x(a%field_map(j_block_col)%global_local_pos(i_entry), 1:n_rhs) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(y_field(n_owned_row_field, n_rhs), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do i_entry = 1, n_owned_row_field + y_field(i_entry, 1:n_rhs) = y(a%field_map(i_block_row)%global_local_pos(i_entry), 1:n_rhs) + end do + call a%block_storage%mats(i_block_row, j_block_col)%a%csmm( & + & alpha, x_field, sone, y_field, info, trans_op) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmm') + return + end if + do i_entry = 1, n_owned_row_field + y(a%field_map(i_block_row)%global_local_pos(i_entry), 1:n_rhs) = y_field(i_entry, 1:n_rhs) + end do + deallocate(y_field) + end if + end do + deallocate(x_field) + end do + end subroutine psb_s_nest_base_csmm + + ! cp_to_coo: assemble all the blocks into a single local COO in the + ! global-local layout (rows = concatenated owned rows, columns = the + ! operator's column space). This is the core conversion hook: the generic + ! base-class machinery builds cscnv, csclip, tril/triu, ... on top of it. + subroutine psb_s_nest_base_cp_to_coo(a, b, info) + use psb_s_base_mat_mod, only : psb_s_coo_sparse_mat + class(psb_s_nest_base_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_s_coo_sparse_mat) :: block_coo + integer(psb_ipk_) :: i_field, j_field, k_entry, n_entries, out_pos, owned_offset + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_cp_to_coo' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + call b%allocate(a%get_nrows(), a%get_ncols(), a%get_nzeros()) + out_pos = 0 + owned_offset = 0 + do i_field = 1, a%n_fields + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%cp_to_coo(block_coo, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block cp_to_coo') + return + end if + n_entries = block_coo%get_nzeros() + do k_entry = 1, n_entries + b%ia(out_pos+k_entry) = owned_offset + block_coo%ia(k_entry) + b%ja(out_pos+k_entry) = a%field_map(j_field)%global_local_pos(block_coo%ja(k_entry)) + b%val(out_pos+k_entry) = block_coo%val(k_entry) + end do + out_pos = out_pos + n_entries + call block_coo%free() + end do + owned_offset = owned_offset + a%field_map(i_field)%n_owned + end do + call b%set_nzeros(out_pos) + call b%set_dupl(psb_dupl_add_) + call b%fix(info) + if (info /= psb_success_) & + & call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix') + end subroutine psb_s_nest_base_cp_to_coo + + ! mv_to_coo: the adapter does not own the blocks, so "move" degenerates to + ! copy + detach of the adapter + subroutine psb_s_nest_base_mv_to_coo(a, b, info) + use psb_s_base_mat_mod, only : psb_s_coo_sparse_mat + class(psb_s_nest_base_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + call a%cp_to_coo(b, info) + if (info == psb_success_) call a%free() + end subroutine psb_s_nest_base_mv_to_coo + + ! rowsum: row sums (matrix-valued type), accumulated across the blocks of + ! each row field; d is in the global-local row layout + subroutine psb_s_nest_base_rowsum(d, a) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + real(psb_spk_), allocatable :: block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset + + d(:) = szero + if (.not. associated(a%block_storage)) return + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + allocate(block_sums(n_owned)) + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%rowsum(block_sums) + do k_entry = 1, n_owned + d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) + end do + end do + deallocate(block_sums) + owned_offset = owned_offset + n_owned + end do + end subroutine psb_s_nest_base_rowsum + + ! arwsum: absolute row sums (always real-valued) + subroutine psb_s_nest_base_arwsum(d, a) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + real(psb_spk_), allocatable :: block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset + + d(:) = szero + if (.not. associated(a%block_storage)) return + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + allocate(block_sums(n_owned)) + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%arwsum(block_sums) + do k_entry = 1, n_owned + d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) + end do + end do + deallocate(block_sums) + owned_offset = owned_offset + n_owned + end do + end subroutine psb_s_nest_base_arwsum + + ! colsum: column sums (matrix-valued type) in the operator's column space, + ! accumulated across the blocks of each column field + subroutine psb_s_nest_base_colsum(d, a) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + real(psb_spk_), allocatable :: field_sums(:), block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_local + + d(:) = szero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(field_sums(n_local), block_sums(n_local)) + field_sums(:) = szero + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%colsum(block_sums) + field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) + end do + do k_entry = 1, n_local + d(a%field_map(j_field)%global_local_pos(k_entry)) = field_sums(k_entry) + end do + deallocate(field_sums, block_sums) + end do + end subroutine psb_s_nest_base_colsum + + ! aclsum: absolute column sums (always real-valued) + subroutine psb_s_nest_base_aclsum(d, a) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + real(psb_spk_), allocatable :: field_sums(:), block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_local + + d(:) = szero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(field_sums(n_local), block_sums(n_local)) + field_sums(:) = szero + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%aclsum(block_sums) + field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) + end do + do k_entry = 1, n_local + d(a%field_map(j_field)%global_local_pos(k_entry)) = field_sums(k_entry) + end do + deallocate(field_sums, block_sums) + end do + end subroutine psb_s_nest_base_aclsum + + ! maxval / infinity norm / 1-norm, by delegation/accumulation over blocks + function psb_s_nest_base_maxval(a) result(res) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_) :: res + integer(psb_ipk_) :: i_field, j_field + res = szero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + do i_field = 1, a%n_fields + if (a%block_storage%has_block(i_field, j_field)) & + & res = max(res, a%block_storage%mats(i_field,j_field)%a%maxval()) + end do + end do + end function psb_s_nest_base_maxval + + function psb_s_nest_base_csnmi(a) result(res) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_) :: res + real(psb_spk_), allocatable :: row_sums(:) + res = szero + if (a%get_nrows() <= 0) return + allocate(row_sums(a%get_nrows())) + call psb_s_nest_base_arwsum(row_sums, a) + res = maxval(row_sums) + end function psb_s_nest_base_csnmi + + function psb_s_nest_base_csnm1(a) result(res) + class(psb_s_nest_base_mat), intent(in) :: a + real(psb_spk_) :: res + real(psb_spk_), allocatable :: col_sums(:) + res = szero + if (a%get_ncols() <= 0) return + allocate(col_sums(a%get_ncols())) + call psb_s_nest_base_aclsum(col_sums, a) + res = maxval(col_sums) + end function psb_s_nest_base_csnm1 + + ! scals/scal: scaling acts on the underlying blocks (the operator is a view) + subroutine psb_s_nest_base_scals(d, a, info) + class(psb_s_nest_base_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field, j_field + character(len=24) :: name + info = psb_success_ + name = 'psb_s_nest_scals' + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_mat_state_; call psb_errpush(info, name); return + end if + do j_field = 1, a%n_fields + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal(d, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal'); return + end if + end do + end do + end subroutine psb_s_nest_base_scals + + subroutine psb_s_nest_base_scal(d, a, info, side) + class(psb_s_nest_base_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + real(psb_spk_), allocatable :: d_field(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, n_local, owned_offset + character :: side_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_scal' + side_ = 'L' + if (present(side)) side_ = side + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_mat_state_; call psb_errpush(info, name); return + end if + + if (side_ == 'L' .or. side_ == 'l') then + ! row scaling: each row field uses its owned slice of d + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal( & + & d(owned_offset+1:owned_offset+n_owned), info, side='L') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal L'); return + end if + end do + owned_offset = owned_offset + n_owned + end do + else + ! column scaling: each column field gathers its slice of d + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(d_field(n_local)) + do k_entry = 1, n_local + d_field(k_entry) = d(a%field_map(j_field)%global_local_pos(k_entry)) + end do + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal(d_field, info, side='R') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal R'); return + end if + end do + deallocate(d_field) + end do + end if + end subroutine psb_s_nest_base_scal + + ! clone: the adapter is a view, so the clone shares the blocks and the grid + ! descriptor (pointers) while re-owning its private gather index vectors + subroutine psb_s_nest_base_clone(a, b, info) + class(psb_s_nest_base_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field + + info = psb_success_ + if (allocated(b)) deallocate(b) + allocate(b, source=a, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_s_nest_clone'); return + end if + select type (b_nest => b) + type is (psb_s_nest_base_mat) + if (allocated(b_nest%field_map)) then + do i_field = 1, size(b_nest%field_map) + ! the sourced copy shares a's gather_pos targets: re-own fresh copies + b_nest%field_map(i_field)%gather_pos => null() + allocate(b_nest%field_map(i_field)%gather_pos, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_s_nest_clone'); return + end if + call b_nest%field_map(i_field)%gather_pos%bld( & + & b_nest%field_map(i_field)%global_local_pos) + end do + end if + end select + end subroutine psb_s_nest_base_clone + + subroutine psb_s_nest_base_mold(a, b, info) + class(psb_s_nest_base_mat), intent(in) :: a + class(psb_s_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + if (allocated(b)) deallocate(b) + allocate(b, mold=a, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_s_nest_mold') + end if + end subroutine psb_s_nest_base_mold + + ! sizeof: blocks + gather maps (the adapter does not own the descriptors) + function psb_s_nest_base_sizeof(a) result(res) + class(psb_s_nest_base_mat), intent(in) :: a + integer(psb_epk_) :: res + integer(psb_ipk_) :: i_field + res = 8 + if (associated(a%block_storage)) res = res + a%block_storage%sizeof() + if (allocated(a%field_map)) then + do i_field = 1, size(a%field_map) + if (allocated(a%field_map(i_field)%global_local_pos)) & + & res = res + psb_sizeof_ip * size(a%field_map(i_field)%global_local_pos) + end do + end if + end function psb_s_nest_base_sizeof + + ! Selective (regime 2) application of a SINGLE block: + ! y_field = alpha * A(i_block_row, j_block_col) * x_field + beta * y_field + ! x_field is the column-field local vector (owned + ghosts) ALREADY halo-exchanged + ! by the caller; y_field is the row-field owned local vector. The caller chooses + ! the exchange regime (the union halo, or just this block's halo), so this + ! routine is purely local. It is FORMAT-AGNOSTIC: it dispatches to the block's + ! own polymorphic csmv, so the block may be CSR, COO, ... independently of the + ! other blocks. (The full-operator matvec, regime 1, is psb_s_nest_base_csmv.) + subroutine psb_s_nest_apply_block(nest_op, i_block_row, j_block_col, alpha, x_field, beta, y_field, info) + type(psb_s_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + real(psb_spk_), intent(in) :: alpha, beta, x_field(:) + real(psb_spk_), intent(inout) :: y_field(:) + integer(psb_ipk_), intent(out) :: info + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_apply_block' + + if (.not. associated(nest_op%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (.not. nest_op%block_storage%has_block(i_block_row, j_block_col)) then + ! absent block contributes zero: y_field <- beta * y_field + if (beta == szero) then + y_field(:) = szero + else if (beta /= sone) then + y_field(:) = beta * y_field(:) + end if + return + end if + + ! polymorphic dispatch: the block applies its own format (CSR/COO/...) + call nest_op%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, beta, y_field, info) + if (info /= psb_success_) & + & call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv') + + end subroutine psb_s_nest_apply_block + + ! ==================================================================== + ! Field-split interface (for the block preconditioner). + ! Exposes the field structure so a fieldsplit/Schur preconditioner can: + ! - know how many fields there are and their owned sizes; + ! - get a block as a standard psb_sspmat_type (sub-preconditioner on A, + ! Schur-complement matvecs with B / B^T); + ! - get a field descriptor (run a field-level Krylov / halo exchange); + ! - restrict the global vector to a field sub-vector and prolong it back. + ! ==================================================================== + + function psb_s_nest_get_n_fields(nest_op) result(n_fields) + type(psb_s_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_) :: n_fields + n_fields = nest_op%n_fields + end function psb_s_nest_get_n_fields + + function psb_s_nest_get_field_owned(nest_op, field) result(n_owned) + type(psb_s_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + integer(psb_ipk_) :: n_owned + n_owned = 0 + if (allocated(nest_op%field_map) .and. field >= 1 .and. field <= nest_op%n_fields) & + & n_owned = nest_op%field_map(field)%n_owned + end function psb_s_nest_get_field_owned + + ! Pointer to block (i,j) as a standard psb_sspmat_type (null if absent). + function psb_s_nest_get_block(nest_op, i_block_row, j_block_col) result(block_ptr) + type(psb_s_nest_base_mat), target, intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + type(psb_sspmat_type), pointer :: block_ptr + block_ptr => null() + if (associated(nest_op%block_storage)) then + if (nest_op%block_storage%has_block(i_block_row, j_block_col)) & + & block_ptr => nest_op%block_storage%mats(i_block_row, j_block_col) + end if + end function psb_s_nest_get_block + + ! Pointer to field k's descriptor (null if not set up). + function psb_s_nest_get_field_desc(nest_op, field) result(desc_ptr) + type(psb_s_nest_base_mat), target, intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + type(psb_desc_type), pointer :: desc_ptr + desc_ptr => null() + if (associated(nest_op%grid_desc) .and. field >= 1 .and. field <= nest_op%n_fields) & + & desc_ptr => nest_op%grid_desc%descs(1, field) + end function psb_s_nest_get_field_desc + + ! Restrict: extract field k's OWNED sub-vector from the global local vector. + subroutine psb_s_nest_restrict_field(nest_op, field, x_global, x_field, info) + type(psb_s_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + real(psb_spk_), intent(in) :: x_global(:) + real(psb_spk_), intent(out) :: x_field(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_entry, n_owned + info = psb_success_ + if (field < 1 .or. field > nest_op%n_fields) then + info = psb_err_invalid_input_; return + end if + n_owned = nest_op%field_map(field)%n_owned + do i_entry = 1, n_owned + x_field(i_entry) = x_global(nest_op%field_map(field)%global_local_pos(i_entry)) + end do + end subroutine psb_s_nest_restrict_field + + ! Prolong: insert field k's OWNED sub-vector into the global local vector. + subroutine psb_s_nest_prolong_field(nest_op, field, x_field, x_global, info) + type(psb_s_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + real(psb_spk_), intent(in) :: x_field(:) + real(psb_spk_), intent(inout) :: x_global(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_entry, n_owned + info = psb_success_ + if (field < 1 .or. field > nest_op%n_fields) then + info = psb_err_invalid_input_; return + end if + n_owned = nest_op%field_map(field)%n_owned + do i_entry = 1, n_owned + x_global(nest_op%field_map(field)%global_local_pos(i_entry)) = x_field(i_entry) + end do + end subroutine psb_s_nest_prolong_field + +end module psb_s_nest_base_mat_mod diff --git a/base/modules/serial/psb_s_nest_mat_mod.f90 b/base/modules/serial/psb_s_nest_mat_mod.f90 new file mode 100644 index 000000000..e78be90e0 --- /dev/null +++ b/base/modules/serial/psb_s_nest_mat_mod.f90 @@ -0,0 +1,149 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific without permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! module: psb_s_nest_mat_mod +! Author: Simone Staccone (Stack-1) +! +! Defines psb_s_nest_sparse_mat: a block-structured distributed sparse +! matrix for double precision real arithmetic. +! +! The matrix is stored as a 2-D array of psb_sspmat_type sub-matrices. +! Block presence is determined directly from the sub-matrix storage: a block +! (i,j) is present iff mats(i,j)%a is allocated (absent blocks contribute zero +! to any product). There is no separate presence flag array. +! +! Descriptor convention (current nested design) +! --------------------------------------------- +! Each matrix block (i,j) is associated with descs(i,j) from the +! corresponding psb_desc_nest_type. Nested tools (psb_spall_nest, +! psb_spins_nest, psb_spasb_nest, psb_spmm) consistently pass +! descs(i,j) together with mats(i,j). +! +! A block may be structurally absent (NULL/zero): this is represented by +! mats(i,j) left unbuilt (mats(i,j)%a not allocated). In that case the +! block contributes zero and is skipped by nested kernels. +! +! Descriptor storage is distinct from matrix presence: descriptors are +! typically defined for all block positions in descs(:,:), while actual +! matrix blocks may be present only on a subset. +! +! Reference examples in test/pdegen: +! * psb_s_pde_nest.full.F90 (A(2,2) left NULL, mats(2,2)%a not allocated) +! * psb_s_nest_tools.F90 and psb_s_pde_nest_full_tools.F90 +! (2-D desc_nest%descs(i,j) used in nested allocation/assembly). +! +module psb_s_nest_mat_mod + use psb_s_mat_mod + implicit none + + type :: psb_s_nest_sparse_mat + integer(psb_ipk_) :: nrblocks = 0 + integer(psb_ipk_) :: ncblocks = 0 + type(psb_sspmat_type), allocatable :: mats(:,:) + contains + procedure :: get_nrblocks => psb_s_nest_mat_get_nrb + procedure :: get_ncblocks => psb_s_nest_mat_get_ncb + procedure :: has_block => psb_s_nest_mat_has_block + procedure :: sizeof => psb_s_nest_mat_sizeof + procedure :: free => psb_s_nest_mat_free + end type psb_s_nest_sparse_mat + +contains + + ! get_nrblocks / get_ncblocks + function psb_s_nest_mat_get_nrb(a) result(n) + class(psb_s_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: n + n = a%nrblocks + end function psb_s_nest_mat_get_nrb + + function psb_s_nest_mat_get_ncb(a) result(n) + class(psb_s_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: n + n = a%ncblocks + end function psb_s_nest_mat_get_ncb + + ! has_block: return .true. if block (i,j) is non-null + function psb_s_nest_mat_has_block(a, i_block_row, j_block_col) result(has) + class(psb_s_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + logical :: has + + has = .false. + if (i_block_row < 1 .or. i_block_row > a%nrblocks) return + if (j_block_col < 1 .or. j_block_col > a%ncblocks) return + if (.not. allocated(a%mats)) return + ! P3: presence is determined solely by whether the sub-matrix has been + ! built (its polymorphic storage %a is allocated). No parallel flag array. + has = allocated(a%mats(i_block_row, j_block_col)%a) + end function psb_s_nest_mat_has_block + + ! sizeof: total storage across all allocated sub-matrices + function psb_s_nest_mat_sizeof(a) result(total_bytes) + class(psb_s_nest_sparse_mat), intent(in) :: a + integer(psb_epk_) :: total_bytes + integer(psb_ipk_) :: i_block_row, j_block_col + + total_bytes = 0_psb_epk_ + if (allocated(a%mats)) then + do j_block_col = 1, a%ncblocks + do i_block_row = 1, a%nrblocks + if (allocated(a%mats(i_block_row, j_block_col)%a)) & + & total_bytes = total_bytes + a%mats(i_block_row, j_block_col)%sizeof() + end do + end do + end if + end function psb_s_nest_mat_sizeof + + ! free: release all sub-matrices + subroutine psb_s_nest_mat_free(a, info) + class(psb_s_nest_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + + info = 0 + if (allocated(a%mats)) then + do j_block_col = 1, a%ncblocks + do i_block_row = 1, a%nrblocks + if (allocated(a%mats(i_block_row, j_block_col)%a)) then + call a%mats(i_block_row, j_block_col)%free() + end if + end do + end do + deallocate(a%mats, stat=local_info) + if (local_info /= 0 .and. info == 0) info = local_info + end if + a%nrblocks = 0 + a%ncblocks = 0 + end subroutine psb_s_nest_mat_free + +end module psb_s_nest_mat_mod diff --git a/base/modules/serial/psb_z_nest_base_mat_mod.F90 b/base/modules/serial/psb_z_nest_base_mat_mod.F90 new file mode 100644 index 000000000..f33fc1cbe --- /dev/null +++ b/base/modules/serial/psb_z_nest_base_mat_mod.F90 @@ -0,0 +1,1212 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_z_nest_base_mat_mod.F90 +! +! Module: psb_z_nest_base_mat_mod +! Author: Simone Staccone (Stack-1) +! +! Adapter that makes a block-structured (nested) operator look like a standard +! local sparse matrix to PSBLAS: psb_z_nest_base_mat EXTENDS +! psb_z_base_sparse_mat and implements csmv (the local matrix-vector product). +! Wrapped in a psb_zspmat_type and paired with the composed global descriptor +! (see psb_cd_nest_compose), the nested operator can then be fed to psb_spmm, +! psb_krylov and the AMG4PSBLAS preconditioners unchanged (MATNEST-style). +! +! The local vector handed to csmv lives in the GLOBAL local layout produced by +! psb_cd_nest_compose: the owned entries of all fields are concatenated, followed +! by the global halo. For each field we precompute field_map(field)%global_local_pos, +! the positions in that global local vector of the field's own local vector +! (owned entries first, then the field's ghosts), so we can gather the field +! input sub-vector and scatter the field output sub-vector without further +! communication (the halo exchange is done once by psb_spmm on the global desc). +! +module psb_z_nest_base_mat_mod + use psb_const_mod + use psb_error_mod + use psb_realloc_mod, only : psb_ensure_size + use psb_z_base_mat_mod, only : psb_z_base_sparse_mat + use psb_z_base_vect_mod, only : psb_z_base_vect_type + use psb_i_vect_mod, only : psb_i_vect_type + use psb_desc_mod, only : psb_desc_type + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_z_nest_mat_mod, only : psb_z_nest_sparse_mat + use psb_z_mat_mod, only : psb_zspmat_type + implicit none + + ! Per-field gather/scatter map into the global local vector. + ! global_local_pos(1 : n_owned) -> the field's owned entries + ! global_local_pos(n_owned+1 : size) -> the field's ghost (halo) entries + type :: psb_z_nest_field_map + integer(psb_ipk_) :: n_owned = 0 + integer(psb_ipk_), allocatable :: global_local_pos(:) + ! same positions as an encapsulated index vector, for the device-capable + ! gather/scatter (gth/sct) used by vect_mv; pointer so that its target can + ! be synced even when the operator dummy argument is intent(in) + type(psb_i_vect_type), pointer :: gather_pos => null() + end type psb_z_nest_field_map + + type, extends(psb_z_base_sparse_mat) :: psb_z_nest_base_mat + integer(psb_ipk_) :: n_fields = 0 + type(psb_z_nest_sparse_mat), pointer :: block_storage => null() ! blocks (not owned) + type(psb_desc_nest_type), pointer :: grid_desc => null() ! per-field descriptors (not owned) + type(psb_z_nest_field_map), allocatable :: field_map(:) + contains + procedure, pass(a) :: csmv => psb_z_nest_base_csmv + procedure, pass(a) :: get_nzeros => psb_z_nest_base_get_nzeros + procedure, nopass :: get_fmt => psb_z_nest_base_get_fmt + procedure, pass(a) :: free => psb_z_nest_base_free + ! enable the stock PSBLAS preconditioners on the nested operator: + ! get_diag is used by DIAG/JACOBI, csgetrow by BJAC (ILU factorizations + ! go through the format-agnostic csget path) + procedure, pass(a) :: get_diag => psb_z_nest_base_get_diag + procedure, pass(a) :: csgetrow => psb_z_nest_base_csgetrow + ! device-capable matvec on encapsulated vectors: gathers/scatters through + ! the vectors' own gth/sct and runs each block through its vect_mv, so + ! device block formats execute their device kernels + procedure, pass(a) :: vect_mv => psb_z_nest_base_vect_mv + ! full base-class contract (delegating to the blocks): + procedure, pass(a) :: csmm => psb_z_nest_base_csmm + procedure, pass(a) :: cp_to_coo => psb_z_nest_base_cp_to_coo + procedure, pass(a) :: mv_to_coo => psb_z_nest_base_mv_to_coo + procedure, pass(a) :: rowsum => psb_z_nest_base_rowsum + procedure, pass(a) :: arwsum => psb_z_nest_base_arwsum + procedure, pass(a) :: colsum => psb_z_nest_base_colsum + procedure, pass(a) :: aclsum => psb_z_nest_base_aclsum + procedure, pass(a) :: maxval => psb_z_nest_base_maxval + procedure, pass(a) :: spnmi => psb_z_nest_base_csnmi + procedure, pass(a) :: spnm1 => psb_z_nest_base_csnm1 + procedure, pass(a) :: scals => psb_z_nest_base_scals + procedure, pass(a) :: scalv => psb_z_nest_base_scal + procedure, pass(a) :: clone => psb_z_nest_base_clone + procedure, pass(a) :: mold => psb_z_nest_base_mold + procedure, pass(a) :: sizeof => psb_z_nest_base_sizeof + ! NOT implemented on purpose (base error 700 is the intended behaviour): + ! cp_from_coo / mv_from_coo (a nested operator cannot be built from a flat + ! matrix without the field structure), csput (insertions go to the blocks + ! before assembly), cssv/cssm (triangular solve is undefined for a block + ! operator) + end type psb_z_nest_base_mat + + private + public :: psb_z_nest_base_mat, psb_z_nest_base_setup, psb_z_nest_apply_block + ! field-split interface (for the block preconditioner) + public :: psb_z_nest_get_n_fields, psb_z_nest_get_field_owned, & + & psb_z_nest_get_block, psb_z_nest_get_field_desc, & + & psb_z_nest_restrict_field, psb_z_nest_prolong_field + +contains + + function psb_z_nest_base_get_fmt() result(format_name) + character(len=5) :: format_name + format_name = 'NEST' + end function psb_z_nest_base_get_fmt + + ! free: the nested operator does NOT own block_storage / grid_desc (they are + ! pointers into the caller), so we only detach them and release the field maps. + subroutine psb_z_nest_base_free(a) + class(psb_z_nest_base_mat), intent(inout) :: a + integer(psb_ipk_) :: i_field, local_info + if (allocated(a%field_map)) then + do i_field = 1, size(a%field_map) + if (associated(a%field_map(i_field)%gather_pos)) then + call a%field_map(i_field)%gather_pos%free(local_info) + deallocate(a%field_map(i_field)%gather_pos) + a%field_map(i_field)%gather_pos => null() + end if + end do + deallocate(a%field_map) + end if + a%block_storage => null() + a%grid_desc => null() + a%n_fields = 0 + call a%set_null() + end subroutine psb_z_nest_base_free + + function psb_z_nest_base_get_nzeros(a) result(total_nzeros) + class(psb_z_nest_base_mat), intent(in) :: a + integer(psb_ipk_) :: total_nzeros + integer(psb_ipk_) :: i_block_row, j_block_col + total_nzeros = 0 + if (associated(a%block_storage)) then + do j_block_col = 1, a%block_storage%ncblocks + do i_block_row = 1, a%block_storage%nrblocks + if (a%block_storage%has_block(i_block_row, j_block_col)) & + & total_nzeros = total_nzeros + & + & a%block_storage%mats(i_block_row, j_block_col)%get_nzeros() + end do + end do + end if + end function psb_z_nest_base_get_nzeros + + ! get_diag: diagonal of the global operator. In the global-local layout the + ! owned entries of field i occupy positions owned_offset+1..owned_offset+n_owned, + ! and for owned indices the field-local column k maps to the same global-local + ! position as row k, so the global diagonal is the concatenation of the + ! diagonals of the diagonal blocks (i,i); absent blocks contribute zeros + ! (e.g. the (2,2) block of a saddle-point operator). + subroutine psb_z_nest_base_get_diag(a, d, info) + class(psb_z_nest_base_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + complex(psb_dpk_), allocatable :: block_diag(:) + integer(psb_ipk_) :: i_field, n_owned, owned_offset + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_get_diag' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (size(d) < a%get_nrows()) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='d too small') + return + end if + + d(1:a%get_nrows()) = zzero + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + if (a%block_storage%has_block(i_field, i_field)) then + allocate(block_diag(n_owned), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call a%block_storage%mats(i_field,i_field)%a%get_diag(block_diag, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block get_diag') + return + end if + d(owned_offset+1 : owned_offset+n_owned) = block_diag(1:n_owned) + deallocate(block_diag) + end if + owned_offset = owned_offset + n_owned + end do + end subroutine psb_z_nest_base_get_diag + + ! csgetrow: extract local rows imin..imax of the global operator as COO + ! triplets, with columns in the global-local layout (the operator's column + ! space). Each global-local row r belongs to one field i (row k within the + ! field); its entries are the union over j of row k of block (i,j), with the + ! block-local column c remapped through field_map(j)%global_local_pos(c). + ! This is the format-agnostic access path used by the ILU factorizations of + ! the BJAC preconditioner (via csget/csgetblk). + subroutine psb_z_nest_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) + class(psb_z_nest_base_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale,chksz + + integer(psb_ipk_), allocatable :: block_row_ia(:), block_row_ja(:) + complex(psb_dpk_), allocatable :: block_row_val(:) + integer(psb_ipk_) :: jmin_, jmax_, nzin_, out_pos + integer(psb_ipk_) :: r_row, i_field, j_field, k_in_field, owned_offset + integer(psb_ipk_) :: block_nz, t_entry, global_local_col + logical :: append_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_csgetrow' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (present(iren)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='iren not supported'); return + end if + if (present(rscale)) then + if (rscale) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='rscale not supported'); return + end if + end if + if (present(cscale)) then + if (cscale) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='cscale not supported'); return + end if + end if + + jmin_ = 1 + jmax_ = a%get_ncols() + if (present(jmin)) jmin_ = jmin + if (present(jmax)) jmax_ = jmax + append_ = .false. + if (present(append)) append_ = append + nzin_ = 0 + if (append_ .and. present(nzin)) nzin_ = nzin + + nz = 0 + out_pos = nzin_ + + do r_row = max(imin, 1), min(imax, a%get_nrows()) + ! locate the field owning global-local row r_row + owned_offset = 0 + i_field = 0 + do while (i_field < a%n_fields) + i_field = i_field + 1 + if (r_row <= owned_offset + a%field_map(i_field)%n_owned) exit + owned_offset = owned_offset + a%field_map(i_field)%n_owned + end do + k_in_field = r_row - owned_offset + + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%csgetrow(k_in_field, k_in_field, & + & block_nz, block_row_ia, block_row_ja, block_row_val, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csgetrow') + return + end if + do t_entry = 1, block_nz + global_local_col = a%field_map(j_field)%global_local_pos(block_row_ja(t_entry)) + if ((global_local_col < jmin_) .or. (global_local_col > jmax_)) cycle + out_pos = out_pos + 1 + call psb_ensure_size(out_pos, ia, info) + if (info == psb_success_) call psb_ensure_size(out_pos, ja, info) + if (info == psb_success_) call psb_ensure_size(out_pos, val, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ia(out_pos) = r_row + ja(out_pos) = global_local_col + val(out_pos) = block_row_val(t_entry) + nz = nz + 1 + end do + end do + end do + end subroutine psb_z_nest_base_csgetrow + + ! vect_mv: matvec on encapsulated vectors (the path taken by psb_spmm with + ! psb_z_vect_type). Instead of falling back to the host-array csmv, it + ! (1) gathers each column-field sub-vector through the vector's own gth with + ! an encapsulated index vector (a device kernel on device vectors), + ! (2) runs each block through its vect_mv (device formats execute their own + ! device kernels), with per-field work vectors allocated with mold=x so + ! they share the dynamic type of the incoming vectors, + ! (3) scatters each row-field result back through the vector's own sct. + ! Host/device traffic is limited to the compact field buffers; on plain host + ! vectors this is exactly equivalent to the array csmv. + subroutine psb_z_nest_base_vect_mv(alpha, a, x, beta, y, info, trans) + class(psb_z_nest_base_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + class(psb_z_base_vect_type), allocatable :: x_field_vec, y_field_vec + complex(psb_dpk_), allocatable :: x_field_buf(:), y_field_buf(:) + complex(psb_dpk_) :: block_beta + integer(psb_ipk_) :: i_field, j_field, n_owned, n_local, local_info + logical :: row_has_blocks + character :: trans_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_vect_mv' + + trans_ = 'N' + if (present(trans)) trans_ = trans + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (trans_ /= 'N' .and. trans_ /= 'n') then + ! transposed product: fall back to host arrays (rare path) + block + complex(psb_dpk_), allocatable :: x_host(:), y_host(:) + x_host = x%get_vect() + y_host = y%get_vect() + call psb_z_nest_base_csmv_t(alpha, a, x_host, beta, y_host, info, trans_) + call y%bld(y_host) + end block + return + end if + + ! work vectors share the dynamic type of the incoming vectors + allocate(x_field_vec, mold=x, stat=info) + if (info == 0) allocate(y_field_vec, mold=y, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + call psb_ensure_size(n_owned, y_field_buf, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + row_has_blocks = .false. + block_beta = zzero + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + + ! gather the column-field sub-vector (owned + ghosts) from x + n_local = size(a%field_map(j_field)%global_local_pos) + call psb_ensure_size(n_local, x_field_buf, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call x%gth(ione, int(n_local, psb_mpk_), & + & a%field_map(j_field)%gather_pos%v, x_field_buf) + call x_field_vec%free(local_info) + call x_field_vec%bld(x_field_buf(1:n_local)) + + if (.not. row_has_blocks) then + ! first block of this row field: (re)build the accumulator at the + ! right size, zeroed + y_field_buf(1:n_owned) = zzero + call y_field_vec%free(local_info) + call y_field_vec%bld(y_field_buf(1:n_owned)) + row_has_blocks = .true. + end if + + ! y_field = alpha * A(i,j) * x_field + block_beta * y_field + call a%block_storage%mats(i_field,j_field)%a%spmm(alpha, x_field_vec, & + & block_beta, y_field_vec, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block vect_mv') + return + end if + block_beta = zone + end do + + ! scatter the row-field result into y (beta applied on the owned rows); + ! a row field with no blocks still rescales its rows by beta + if (row_has_blocks) then + y_field_buf(1:n_owned) = y_field_vec%get_vect() + else + y_field_buf(1:n_owned) = zzero + end if + call y%sct(ione, int(n_owned, psb_mpk_), & + & a%field_map(i_field)%gather_pos%v, y_field_buf, beta) + end do + + call x_field_vec%free(local_info) + call y_field_vec%free(local_info) + end subroutine psb_z_nest_base_vect_mv + + ! Build the per-field gather maps and set the local dimensions, from the nested + ! grid descriptor (per-field distribution desc_grid%descs(1,field)) and the + ! composed global descriptor desc_global (produced by psb_cd_nest_compose). + subroutine psb_z_nest_base_setup(nest_op, block_storage, desc_grid, desc_global, info) + type(psb_z_nest_base_mat), intent(inout) :: nest_op + type(psb_z_nest_sparse_mat), target, intent(in) :: block_storage + type(psb_desc_nest_type), target, intent(in) :: desc_grid + type(psb_desc_type), intent(in) :: desc_global + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_fields, i_field, i_entry + integer(psb_ipk_) :: n_owned, n_local, n_ghost, owned_offset, local_pos + integer(psb_lpk_) :: global_idx + integer(psb_lpk_), allocatable :: field_global_offset(:) + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_base_setup' + + if (desc_grid%nrblocks /= desc_grid%ncblocks) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested block structure must be square') + return + end if + + n_fields = desc_grid%ncblocks + nest_op%n_fields = n_fields + nest_op%grid_desc => desc_grid + nest_op%block_storage => block_storage + + ! global field offsets (used to form ghost global indices) + allocate(field_global_offset(n_fields+1), nest_op%field_map(n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + field_global_offset(1) = 0 + do i_field = 1, n_fields + field_global_offset(i_field+1) = field_global_offset(i_field) & + & + desc_grid%descs(1,i_field)%get_global_rows() + end do + + owned_offset = 0 ! running owned-local offset in the global local vector + do i_field = 1, n_fields + n_owned = desc_grid%descs(1,i_field)%get_local_rows() + n_local = desc_grid%descs(1,i_field)%get_local_cols() + n_ghost = n_local - n_owned + nest_op%field_map(i_field)%n_owned = n_owned + allocate(nest_op%field_map(i_field)%global_local_pos(n_local), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! owned entries: contiguous in the global local vector + do i_entry = 1, n_owned + nest_op%field_map(i_field)%global_local_pos(i_entry) = owned_offset + i_entry + end do + ! ghost entries: locate the field's ghost global index in the global descriptor + do i_entry = 1, n_ghost + call desc_grid%descs(1,i_field)%l2g(n_owned + i_entry, global_idx, info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='l2g'); return + end if + call desc_global%g2l(field_global_offset(i_field) + global_idx, local_pos, info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='g2l'); return + end if + nest_op%field_map(i_field)%global_local_pos(n_owned + i_entry) = local_pos + end do + ! encapsulated copy of the positions for the device-capable gth/sct + allocate(nest_op%field_map(i_field)%gather_pos, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call nest_op%field_map(i_field)%gather_pos%bld(nest_op%field_map(i_field)%global_local_pos) + owned_offset = owned_offset + n_owned + end do + + call nest_op%set_nrows(desc_global%get_local_rows()) + call nest_op%set_ncols(desc_global%get_local_cols()) + call nest_op%set_asb() + + end subroutine psb_z_nest_base_setup + + ! Local block matrix-vector product: y = alpha * A_nest * x + beta * y. + ! x is in the global local layout (owned fields concatenated + global halo); + ! y holds the owned entries (global local rows). + subroutine psb_z_nest_base_csmv(alpha, a, x, beta, y, info, trans) + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + class(psb_z_nest_base_mat), intent(in) :: a + complex(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + complex(psb_dpk_), allocatable :: x_field(:), y_field(:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field + character :: trans_op + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_base_csmv' + trans_op = 'N' + if (present(trans)) trans_op = trans + if (trans_op /= 'N' .and. trans_op /= 'n') then + ! transposed product: the block structure of A^T is the transpose of the + ! block grid, handled by the dedicated kernel below ('T' or 'C') + call psb_z_nest_base_csmv_t(alpha, a, x, beta, y, info, trans_op) + return + end if + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + ! y <- beta * y + if (beta == zzero) then + y(:) = zzero + else if (beta /= zone) then + y(:) = beta * y(:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(x_field(n_local_col_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! gather the column-field input sub-vector (owned + that field's ghosts) + do i_entry = 1, n_local_col_field + x_field(i_entry) = x(a%field_map(j_block_col)%global_local_pos(i_entry)) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(y_field(n_owned_row_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! current row-field output sub-vector (owned) + do i_entry = 1, n_owned_row_field + y_field(i_entry) = y(a%field_map(i_block_row)%global_local_pos(i_entry)) + end do + ! y_field <- alpha * A(i_block_row, j_block_col) * x_field + y_field + call a%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, zone, y_field, info, trans_op) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv') + return + end if + ! scatter the row-field output sub-vector back into y + do i_entry = 1, n_owned_row_field + y(a%field_map(i_block_row)%global_local_pos(i_entry)) = y_field(i_entry) + end do + deallocate(y_field) + end if + end do + deallocate(x_field) + end do + + end subroutine psb_z_nest_base_csmv + + ! Transposed matvec kernel: y = alpha * A^T * x + beta * y. + ! The block structure of A^T is the transpose of the block grid: + ! y(cols of field j) += alpha * sum_i A(i,j)^T * x(owned rows of field i). + ! x is read on the owned rows of each row field; the result lands on ALL the + ! local columns of each column field (owned + ghosts); the distributed caller + ! (psb_spmm with trans='T') then accumulates the ghost contributions to their + ! owners through the transposed halo exchange. + subroutine psb_z_nest_base_csmv_t(alpha, a, x, beta, y, info, trans) + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + class(psb_z_nest_base_mat), intent(in) :: a + complex(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + complex(psb_dpk_), allocatable :: x_field(:), y_field(:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_base_csmv_t' + + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + ! y <- beta * y (on the whole column space) + if (beta == zzero) then + y(:) = zzero + else if (beta /= zone) then + y(:) = beta * y(:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(y_field(n_local_col_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! current column-field output sub-vector (owned + ghosts) + do i_entry = 1, n_local_col_field + y_field(i_entry) = y(a%field_map(j_block_col)%global_local_pos(i_entry)) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(x_field(n_owned_row_field), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + ! gather the row-field input sub-vector (owned rows only) + do i_entry = 1, n_owned_row_field + x_field(i_entry) = x(a%field_map(i_block_row)%global_local_pos(i_entry)) + end do + ! y_field <- alpha * A(i,j)^T (or ^H) * x_field + y_field + call a%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, zone, y_field, info, trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv T') + return + end if + deallocate(x_field) + end if + end do + + ! scatter the column-field output sub-vector back into y + do i_entry = 1, n_local_col_field + y(a%field_map(j_block_col)%global_local_pos(i_entry)) = y_field(i_entry) + end do + deallocate(y_field) + end do + end subroutine psb_z_nest_base_csmv_t + + ! csmm: multi-RHS product, the 2D analogue of csmv (same gather/scatter + ! per field, the block product is the block's own csmm) + subroutine psb_z_nest_base_csmm(alpha, a, x, beta, y, info, trans) + class(psb_z_nest_base_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + + complex(psb_dpk_), allocatable :: x_field(:,:), y_field(:,:) + integer(psb_ipk_) :: i_block_row, j_block_col, i_entry + integer(psb_ipk_) :: n_local_col_field, n_owned_row_field, n_rhs + character :: trans_op + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_base_csmm' + trans_op = 'N' + if (present(trans)) trans_op = trans + if (trans_op /= 'N' .and. trans_op /= 'n') then + info = psb_err_transpose_not_n_unsupported_ + call psb_errpush(info, name); return + end if + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + n_rhs = min(size(x,2), size(y,2)) + + if (beta == zzero) then + y(:,:) = zzero + else if (beta /= zone) then + y(:,:) = beta * y(:,:) + end if + + do j_block_col = 1, a%n_fields + n_local_col_field = size(a%field_map(j_block_col)%global_local_pos) + allocate(x_field(n_local_col_field, n_rhs), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do i_entry = 1, n_local_col_field + x_field(i_entry, 1:n_rhs) = x(a%field_map(j_block_col)%global_local_pos(i_entry), 1:n_rhs) + end do + + do i_block_row = 1, a%n_fields + if (a%block_storage%has_block(i_block_row, j_block_col)) then + n_owned_row_field = a%field_map(i_block_row)%n_owned + allocate(y_field(n_owned_row_field, n_rhs), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do i_entry = 1, n_owned_row_field + y_field(i_entry, 1:n_rhs) = y(a%field_map(i_block_row)%global_local_pos(i_entry), 1:n_rhs) + end do + call a%block_storage%mats(i_block_row, j_block_col)%a%csmm( & + & alpha, x_field, zone, y_field, info, trans_op) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmm') + return + end if + do i_entry = 1, n_owned_row_field + y(a%field_map(i_block_row)%global_local_pos(i_entry), 1:n_rhs) = y_field(i_entry, 1:n_rhs) + end do + deallocate(y_field) + end if + end do + deallocate(x_field) + end do + end subroutine psb_z_nest_base_csmm + + ! cp_to_coo: assemble all the blocks into a single local COO in the + ! global-local layout (rows = concatenated owned rows, columns = the + ! operator's column space). This is the core conversion hook: the generic + ! base-class machinery builds cscnv, csclip, tril/triu, ... on top of it. + subroutine psb_z_nest_base_cp_to_coo(a, b, info) + use psb_z_base_mat_mod, only : psb_z_coo_sparse_mat + class(psb_z_nest_base_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_z_coo_sparse_mat) :: block_coo + integer(psb_ipk_) :: i_field, j_field, k_entry, n_entries, out_pos, owned_offset + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_cp_to_coo' + + if (.not. (associated(a%block_storage) .and. allocated(a%field_map))) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + + call b%allocate(a%get_nrows(), a%get_ncols(), a%get_nzeros()) + out_pos = 0 + owned_offset = 0 + do i_field = 1, a%n_fields + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%cp_to_coo(block_coo, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block cp_to_coo') + return + end if + n_entries = block_coo%get_nzeros() + do k_entry = 1, n_entries + b%ia(out_pos+k_entry) = owned_offset + block_coo%ia(k_entry) + b%ja(out_pos+k_entry) = a%field_map(j_field)%global_local_pos(block_coo%ja(k_entry)) + b%val(out_pos+k_entry) = block_coo%val(k_entry) + end do + out_pos = out_pos + n_entries + call block_coo%free() + end do + owned_offset = owned_offset + a%field_map(i_field)%n_owned + end do + call b%set_nzeros(out_pos) + call b%set_dupl(psb_dupl_add_) + call b%fix(info) + if (info /= psb_success_) & + & call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix') + end subroutine psb_z_nest_base_cp_to_coo + + ! mv_to_coo: the adapter does not own the blocks, so "move" degenerates to + ! copy + detach of the adapter + subroutine psb_z_nest_base_mv_to_coo(a, b, info) + use psb_z_base_mat_mod, only : psb_z_coo_sparse_mat + class(psb_z_nest_base_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + call a%cp_to_coo(b, info) + if (info == psb_success_) call a%free() + end subroutine psb_z_nest_base_mv_to_coo + + ! rowsum: row sums (matrix-valued type), accumulated across the blocks of + ! each row field; d is in the global-local row layout + subroutine psb_z_nest_base_rowsum(d, a) + class(psb_z_nest_base_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + complex(psb_dpk_), allocatable :: block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset + + d(:) = zzero + if (.not. associated(a%block_storage)) return + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + allocate(block_sums(n_owned)) + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%rowsum(block_sums) + do k_entry = 1, n_owned + d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) + end do + end do + deallocate(block_sums) + owned_offset = owned_offset + n_owned + end do + end subroutine psb_z_nest_base_rowsum + + ! arwsum: absolute row sums (always real-valued) + subroutine psb_z_nest_base_arwsum(d, a) + class(psb_z_nest_base_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + real(psb_dpk_), allocatable :: block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, owned_offset + + d(:) = dzero + if (.not. associated(a%block_storage)) return + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + allocate(block_sums(n_owned)) + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%arwsum(block_sums) + do k_entry = 1, n_owned + d(owned_offset+k_entry) = d(owned_offset+k_entry) + block_sums(k_entry) + end do + end do + deallocate(block_sums) + owned_offset = owned_offset + n_owned + end do + end subroutine psb_z_nest_base_arwsum + + ! colsum: column sums (matrix-valued type) in the operator's column space, + ! accumulated across the blocks of each column field + subroutine psb_z_nest_base_colsum(d, a) + class(psb_z_nest_base_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + complex(psb_dpk_), allocatable :: field_sums(:), block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_local + + d(:) = zzero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(field_sums(n_local), block_sums(n_local)) + field_sums(:) = zzero + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%colsum(block_sums) + field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) + end do + do k_entry = 1, n_local + d(a%field_map(j_field)%global_local_pos(k_entry)) = field_sums(k_entry) + end do + deallocate(field_sums, block_sums) + end do + end subroutine psb_z_nest_base_colsum + + ! aclsum: absolute column sums (always real-valued) + subroutine psb_z_nest_base_aclsum(d, a) + class(psb_z_nest_base_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + real(psb_dpk_), allocatable :: field_sums(:), block_sums(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_local + + d(:) = dzero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(field_sums(n_local), block_sums(n_local)) + field_sums(:) = dzero + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%aclsum(block_sums) + field_sums(1:n_local) = field_sums(1:n_local) + block_sums(1:n_local) + end do + do k_entry = 1, n_local + d(a%field_map(j_field)%global_local_pos(k_entry)) = field_sums(k_entry) + end do + deallocate(field_sums, block_sums) + end do + end subroutine psb_z_nest_base_aclsum + + ! maxval / infinity norm / 1-norm, by delegation/accumulation over blocks + function psb_z_nest_base_maxval(a) result(res) + class(psb_z_nest_base_mat), intent(in) :: a + real(psb_dpk_) :: res + integer(psb_ipk_) :: i_field, j_field + res = dzero + if (.not. associated(a%block_storage)) return + do j_field = 1, a%n_fields + do i_field = 1, a%n_fields + if (a%block_storage%has_block(i_field, j_field)) & + & res = max(res, a%block_storage%mats(i_field,j_field)%a%maxval()) + end do + end do + end function psb_z_nest_base_maxval + + function psb_z_nest_base_csnmi(a) result(res) + class(psb_z_nest_base_mat), intent(in) :: a + real(psb_dpk_) :: res + real(psb_dpk_), allocatable :: row_sums(:) + res = dzero + if (a%get_nrows() <= 0) return + allocate(row_sums(a%get_nrows())) + call psb_z_nest_base_arwsum(row_sums, a) + res = maxval(row_sums) + end function psb_z_nest_base_csnmi + + function psb_z_nest_base_csnm1(a) result(res) + class(psb_z_nest_base_mat), intent(in) :: a + real(psb_dpk_) :: res + real(psb_dpk_), allocatable :: col_sums(:) + res = dzero + if (a%get_ncols() <= 0) return + allocate(col_sums(a%get_ncols())) + call psb_z_nest_base_aclsum(col_sums, a) + res = maxval(col_sums) + end function psb_z_nest_base_csnm1 + + ! scals/scal: scaling acts on the underlying blocks (the operator is a view) + subroutine psb_z_nest_base_scals(d, a, info) + class(psb_z_nest_base_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field, j_field + character(len=24) :: name + info = psb_success_ + name = 'psb_z_nest_scals' + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_mat_state_; call psb_errpush(info, name); return + end if + do j_field = 1, a%n_fields + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal(d, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal'); return + end if + end do + end do + end subroutine psb_z_nest_base_scals + + subroutine psb_z_nest_base_scal(d, a, info, side) + class(psb_z_nest_base_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + complex(psb_dpk_), allocatable :: d_field(:) + integer(psb_ipk_) :: i_field, j_field, k_entry, n_owned, n_local, owned_offset + character :: side_ + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_scal' + side_ = 'L' + if (present(side)) side_ = side + if (.not. associated(a%block_storage)) then + info = psb_err_invalid_mat_state_; call psb_errpush(info, name); return + end if + + if (side_ == 'L' .or. side_ == 'l') then + ! row scaling: each row field uses its owned slice of d + owned_offset = 0 + do i_field = 1, a%n_fields + n_owned = a%field_map(i_field)%n_owned + do j_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal( & + & d(owned_offset+1:owned_offset+n_owned), info, side='L') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal L'); return + end if + end do + owned_offset = owned_offset + n_owned + end do + else + ! column scaling: each column field gathers its slice of d + do j_field = 1, a%n_fields + n_local = size(a%field_map(j_field)%global_local_pos) + allocate(d_field(n_local)) + do k_entry = 1, n_local + d_field(k_entry) = d(a%field_map(j_field)%global_local_pos(k_entry)) + end do + do i_field = 1, a%n_fields + if (.not. a%block_storage%has_block(i_field, j_field)) cycle + call a%block_storage%mats(i_field,j_field)%a%scal(d_field, info, side='R') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='block scal R'); return + end if + end do + deallocate(d_field) + end do + end if + end subroutine psb_z_nest_base_scal + + ! clone: the adapter is a view, so the clone shares the blocks and the grid + ! descriptor (pointers) while re-owning its private gather index vectors + subroutine psb_z_nest_base_clone(a, b, info) + class(psb_z_nest_base_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field + + info = psb_success_ + if (allocated(b)) deallocate(b) + allocate(b, source=a, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_z_nest_clone'); return + end if + select type (b_nest => b) + type is (psb_z_nest_base_mat) + if (allocated(b_nest%field_map)) then + do i_field = 1, size(b_nest%field_map) + ! the sourced copy shares a's gather_pos targets: re-own fresh copies + b_nest%field_map(i_field)%gather_pos => null() + allocate(b_nest%field_map(i_field)%gather_pos, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_z_nest_clone'); return + end if + call b_nest%field_map(i_field)%gather_pos%bld( & + & b_nest%field_map(i_field)%global_local_pos) + end do + end if + end select + end subroutine psb_z_nest_base_clone + + subroutine psb_z_nest_base_mold(a, b, info) + class(psb_z_nest_base_mat), intent(in) :: a + class(psb_z_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + if (allocated(b)) deallocate(b) + allocate(b, mold=a, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, 'psb_z_nest_mold') + end if + end subroutine psb_z_nest_base_mold + + ! sizeof: blocks + gather maps (the adapter does not own the descriptors) + function psb_z_nest_base_sizeof(a) result(res) + class(psb_z_nest_base_mat), intent(in) :: a + integer(psb_epk_) :: res + integer(psb_ipk_) :: i_field + res = 8 + if (associated(a%block_storage)) res = res + a%block_storage%sizeof() + if (allocated(a%field_map)) then + do i_field = 1, size(a%field_map) + if (allocated(a%field_map(i_field)%global_local_pos)) & + & res = res + psb_sizeof_ip * size(a%field_map(i_field)%global_local_pos) + end do + end if + end function psb_z_nest_base_sizeof + + ! Selective (regime 2) application of a SINGLE block: + ! y_field = alpha * A(i_block_row, j_block_col) * x_field + beta * y_field + ! x_field is the column-field local vector (owned + ghosts) ALREADY halo-exchanged + ! by the caller; y_field is the row-field owned local vector. The caller chooses + ! the exchange regime (the union halo, or just this block's halo), so this + ! routine is purely local. It is FORMAT-AGNOSTIC: it dispatches to the block's + ! own polymorphic csmv, so the block may be CSR, COO, ... independently of the + ! other blocks. (The full-operator matvec, regime 1, is psb_z_nest_base_csmv.) + subroutine psb_z_nest_apply_block(nest_op, i_block_row, j_block_col, alpha, x_field, beta, y_field, info) + type(psb_z_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + complex(psb_dpk_), intent(in) :: alpha, beta, x_field(:) + complex(psb_dpk_), intent(inout) :: y_field(:) + integer(psb_ipk_), intent(out) :: info + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_apply_block' + + if (.not. associated(nest_op%block_storage)) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='nested operator not set up') + return + end if + if (.not. nest_op%block_storage%has_block(i_block_row, j_block_col)) then + ! absent block contributes zero: y_field <- beta * y_field + if (beta == zzero) then + y_field(:) = zzero + else if (beta /= zone) then + y_field(:) = beta * y_field(:) + end if + return + end if + + ! polymorphic dispatch: the block applies its own format (CSR/COO/...) + call nest_op%block_storage%mats(i_block_row, j_block_col)%a%csmv( & + & alpha, x_field, beta, y_field, info) + if (info /= psb_success_) & + & call psb_errpush(psb_err_from_subroutine_, name, a_err='block csmv') + + end subroutine psb_z_nest_apply_block + + ! ==================================================================== + ! Field-split interface (for the block preconditioner). + ! Exposes the field structure so a fieldsplit/Schur preconditioner can: + ! - know how many fields there are and their owned sizes; + ! - get a block as a standard psb_zspmat_type (sub-preconditioner on A, + ! Schur-complement matvecs with B / B^T); + ! - get a field descriptor (run a field-level Krylov / halo exchange); + ! - restrict the global vector to a field sub-vector and prolong it back. + ! ==================================================================== + + function psb_z_nest_get_n_fields(nest_op) result(n_fields) + type(psb_z_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_) :: n_fields + n_fields = nest_op%n_fields + end function psb_z_nest_get_n_fields + + function psb_z_nest_get_field_owned(nest_op, field) result(n_owned) + type(psb_z_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + integer(psb_ipk_) :: n_owned + n_owned = 0 + if (allocated(nest_op%field_map) .and. field >= 1 .and. field <= nest_op%n_fields) & + & n_owned = nest_op%field_map(field)%n_owned + end function psb_z_nest_get_field_owned + + ! Pointer to block (i,j) as a standard psb_zspmat_type (null if absent). + function psb_z_nest_get_block(nest_op, i_block_row, j_block_col) result(block_ptr) + type(psb_z_nest_base_mat), target, intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + type(psb_zspmat_type), pointer :: block_ptr + block_ptr => null() + if (associated(nest_op%block_storage)) then + if (nest_op%block_storage%has_block(i_block_row, j_block_col)) & + & block_ptr => nest_op%block_storage%mats(i_block_row, j_block_col) + end if + end function psb_z_nest_get_block + + ! Pointer to field k's descriptor (null if not set up). + function psb_z_nest_get_field_desc(nest_op, field) result(desc_ptr) + type(psb_z_nest_base_mat), target, intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + type(psb_desc_type), pointer :: desc_ptr + desc_ptr => null() + if (associated(nest_op%grid_desc) .and. field >= 1 .and. field <= nest_op%n_fields) & + & desc_ptr => nest_op%grid_desc%descs(1, field) + end function psb_z_nest_get_field_desc + + ! Restrict: extract field k's OWNED sub-vector from the global local vector. + subroutine psb_z_nest_restrict_field(nest_op, field, x_global, x_field, info) + type(psb_z_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + complex(psb_dpk_), intent(in) :: x_global(:) + complex(psb_dpk_), intent(out) :: x_field(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_entry, n_owned + info = psb_success_ + if (field < 1 .or. field > nest_op%n_fields) then + info = psb_err_invalid_input_; return + end if + n_owned = nest_op%field_map(field)%n_owned + do i_entry = 1, n_owned + x_field(i_entry) = x_global(nest_op%field_map(field)%global_local_pos(i_entry)) + end do + end subroutine psb_z_nest_restrict_field + + ! Prolong: insert field k's OWNED sub-vector into the global local vector. + subroutine psb_z_nest_prolong_field(nest_op, field, x_field, x_global, info) + type(psb_z_nest_base_mat), intent(in) :: nest_op + integer(psb_ipk_), intent(in) :: field + complex(psb_dpk_), intent(in) :: x_field(:) + complex(psb_dpk_), intent(inout) :: x_global(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_entry, n_owned + info = psb_success_ + if (field < 1 .or. field > nest_op%n_fields) then + info = psb_err_invalid_input_; return + end if + n_owned = nest_op%field_map(field)%n_owned + do i_entry = 1, n_owned + x_global(nest_op%field_map(field)%global_local_pos(i_entry)) = x_field(i_entry) + end do + end subroutine psb_z_nest_prolong_field + +end module psb_z_nest_base_mat_mod diff --git a/base/modules/serial/psb_z_nest_mat_mod.f90 b/base/modules/serial/psb_z_nest_mat_mod.f90 new file mode 100644 index 000000000..d23a90205 --- /dev/null +++ b/base/modules/serial/psb_z_nest_mat_mod.f90 @@ -0,0 +1,149 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific without permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! module: psb_z_nest_mat_mod +! Author: Simone Staccone (Stack-1) +! +! Defines psb_z_nest_sparse_mat: a block-structured distributed sparse +! matrix for double precision real arithmetic. +! +! The matrix is stored as a 2-D array of psb_zspmat_type sub-matrices. +! Block presence is determined directly from the sub-matrix storage: a block +! (i,j) is present iff mats(i,j)%a is allocated (absent blocks contribute zero +! to any product). There is no separate presence flag array. +! +! Descriptor convention (current nested design) +! --------------------------------------------- +! Each matrix block (i,j) is associated with descs(i,j) from the +! corresponding psb_desc_nest_type. Nested tools (psb_spall_nest, +! psb_spins_nest, psb_spasb_nest, psb_spmm) consistently pass +! descs(i,j) together with mats(i,j). +! +! A block may be structurally absent (NULL/zero): this is represented by +! mats(i,j) left unbuilt (mats(i,j)%a not allocated). In that case the +! block contributes zero and is skipped by nested kernels. +! +! Descriptor storage is distinct from matrix presence: descriptors are +! typically defined for all block positions in descs(:,:), while actual +! matrix blocks may be present only on a subset. +! +! Reference examples in test/pdegen: +! * psb_z_pde_nest.full.F90 (A(2,2) left NULL, mats(2,2)%a not allocated) +! * psb_z_nest_tools.F90 and psb_z_pde_nest_full_tools.F90 +! (2-D desc_nest%descs(i,j) used in nested allocation/assembly). +! +module psb_z_nest_mat_mod + use psb_z_mat_mod + implicit none + + type :: psb_z_nest_sparse_mat + integer(psb_ipk_) :: nrblocks = 0 + integer(psb_ipk_) :: ncblocks = 0 + type(psb_zspmat_type), allocatable :: mats(:,:) + contains + procedure :: get_nrblocks => psb_z_nest_mat_get_nrb + procedure :: get_ncblocks => psb_z_nest_mat_get_ncb + procedure :: has_block => psb_z_nest_mat_has_block + procedure :: sizeof => psb_z_nest_mat_sizeof + procedure :: free => psb_z_nest_mat_free + end type psb_z_nest_sparse_mat + +contains + + ! get_nrblocks / get_ncblocks + function psb_z_nest_mat_get_nrb(a) result(n) + class(psb_z_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: n + n = a%nrblocks + end function psb_z_nest_mat_get_nrb + + function psb_z_nest_mat_get_ncb(a) result(n) + class(psb_z_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: n + n = a%ncblocks + end function psb_z_nest_mat_get_ncb + + ! has_block: return .true. if block (i,j) is non-null + function psb_z_nest_mat_has_block(a, i_block_row, j_block_col) result(has) + class(psb_z_nest_sparse_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: i_block_row, j_block_col + logical :: has + + has = .false. + if (i_block_row < 1 .or. i_block_row > a%nrblocks) return + if (j_block_col < 1 .or. j_block_col > a%ncblocks) return + if (.not. allocated(a%mats)) return + ! P3: presence is determined solely by whether the sub-matrix has been + ! built (its polymorphic storage %a is allocated). No parallel flag array. + has = allocated(a%mats(i_block_row, j_block_col)%a) + end function psb_z_nest_mat_has_block + + ! sizeof: total storage across all allocated sub-matrices + function psb_z_nest_mat_sizeof(a) result(total_bytes) + class(psb_z_nest_sparse_mat), intent(in) :: a + integer(psb_epk_) :: total_bytes + integer(psb_ipk_) :: i_block_row, j_block_col + + total_bytes = 0_psb_epk_ + if (allocated(a%mats)) then + do j_block_col = 1, a%ncblocks + do i_block_row = 1, a%nrblocks + if (allocated(a%mats(i_block_row, j_block_col)%a)) & + & total_bytes = total_bytes + a%mats(i_block_row, j_block_col)%sizeof() + end do + end do + end if + end function psb_z_nest_mat_sizeof + + ! free: release all sub-matrices + subroutine psb_z_nest_mat_free(a, info) + class(psb_z_nest_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + + info = 0 + if (allocated(a%mats)) then + do j_block_col = 1, a%ncblocks + do i_block_row = 1, a%nrblocks + if (allocated(a%mats(i_block_row, j_block_col)%a)) then + call a%mats(i_block_row, j_block_col)%free() + end if + end do + end do + deallocate(a%mats, stat=local_info) + if (local_info /= 0 .and. info == 0) info = local_info + end if + a%nrblocks = 0 + a%ncblocks = 0 + end subroutine psb_z_nest_mat_free + +end module psb_z_nest_mat_mod diff --git a/base/modules/tools/psb_c_nest_builder_mod.F90 b/base/modules/tools/psb_c_nest_builder_mod.F90 new file mode 100644 index 000000000..27838cb02 --- /dev/null +++ b/base/modules/tools/psb_c_nest_builder_mod.F90 @@ -0,0 +1,414 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_c_nest_builder_mod.F90 +! +! Module: psb_c_nest_builder_mod +! Author: Simone Staccone (Stack-1) +! +! User-friendly frontend to build a nested (MATNEST) operator without manually +! managing per-field descriptors, the union halo, composition and setup. +! +! All the boilerplate (identical for every nested operator) is hidden behind a +! single type, psb_c_nest_matrix, with the usual PSBLAS init/ins/asb pattern: +! +! type(psb_c_nest_matrix) :: nested_matrix +! call nested_matrix%init(ctxt, [n1, n2], info) ! 2 fields of global size n1, n2 +! call nested_matrix%ins(1,1, n, rows, cols, vals, info) ! values of block (1,1) = A +! call nested_matrix%ins(1,2, n, rows, cols, vals, info) ! values of block (1,2) = B^T +! call nested_matrix%ins(2,1, n, rows, cols, vals, info) ! values of block (2,1) = B +! ... ! (absent blocks = not inserted) +! call nested_matrix%asb(info) ! assemble: builds a_glob, desc_glob +! +! ! from here on nested_matrix%a_glob and nested_matrix%desc_glob are an +! ! ordinary distributed matrix/descriptor: +! call psb_geall(x, nested_matrix%desc_glob, info) +! call psb_krylov('CG', nested_matrix%a_glob, prec, b, x, eps, nested_matrix%desc_glob, info, ...) +! +! Indices: in ins(block_row, block_col, ...) the rows live in the index space of +! field block_row, the columns in the index space of field block_col (GLOBAL +! field indices, 1..field_size). Each process inserts only the rows it owns +! (PSBLAS convention). Off-diagonal blocks may be rectangular. +! +! NOTE: after asb the object holds consistent internal pointers (a_glob%a points +! to block_storage / grid_desc): do not copy/move the object after assembly. +! +module psb_c_nest_builder_mod + use psb_const_mod + use psb_error_mod, only : psb_errpush + use psb_penv_mod, only : psb_ctxt_type, psb_info + use psb_desc_mod, only : psb_desc_type + use psb_c_mat_mod, only : psb_cspmat_type + use psb_c_base_mat_mod, only : psb_c_base_sparse_mat + use psb_cd_tools_mod, only : psb_cdall, psb_cdins, psb_cdasb + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_c_nest_mat_mod, only : psb_c_nest_sparse_mat + use psb_c_nest_base_mat_mod, only : psb_c_nest_base_mat, psb_c_nest_base_setup + use psb_cd_nest_tools_mod, only : psb_cd_nest_compose + use psb_c_nest_tools_mod, only : psb_c_nest_rect_block + implicit none + + ! growing triplet buffer for a single block + type :: psb_c_nest_block_buffer + integer(psb_ipk_) :: n_entries = 0 + integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:) + complex(psb_spk_), allocatable :: entry_vals(:) + end type psb_c_nest_block_buffer + + type :: psb_c_nest_matrix + type(psb_ctxt_type) :: context + integer(psb_ipk_) :: n_fields = 0 + logical :: assembled = .false. + ! construction state + type(psb_desc_type), allocatable :: field_desc(:) ! one descriptor per field + type(psb_c_nest_block_buffer), allocatable :: block_buffer(:,:) ! triplets per block (i,j) + ! products (owned; the pointers in a_glob%a point in here) + type(psb_c_nest_sparse_mat) :: block_storage + type(psb_desc_nest_type) :: grid_desc + type(psb_cspmat_type) :: a_glob ! the matrix to hand to Krylov + type(psb_desc_type) :: desc_glob ! the global descriptor + contains + procedure, pass(op) :: init => psb_c_nest_op_init + procedure, pass(op) :: ins => psb_c_nest_op_ins + procedure, pass(op) :: asb => psb_c_nest_op_asb + procedure, pass(op) :: free => psb_c_nest_op_free + ! user-friendly queries on the field row distribution (no descriptor + ! jargon needed: these replace field_desc(i)%get_local_rows() / %l2g(...)) + procedure, pass(op) :: get_owned_rows => psb_c_nest_op_get_owned_rows + procedure, pass(op) :: get_owned_row_count => psb_c_nest_op_get_owned_row_count + end type psb_c_nest_matrix + + private + public :: psb_c_nest_matrix + +contains + + ! init: create one descriptor per field (block distribution from the global sizes) + subroutine psb_c_nest_op_init(op, context, field_sizes, info) + class(psb_c_nest_matrix), intent(inout) :: op + type(psb_ctxt_type), intent(in) :: context + integer(psb_lpk_), intent(in) :: field_sizes(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: my_rank, num_procs, n_fields, i_field, field_local_rows + integer(psb_lpk_) :: field_global_size + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_op_init' + + call psb_info(context, my_rank, num_procs) + n_fields = size(field_sizes) + op%context = context + op%n_fields = n_fields + op%assembled = .false. + + allocate(op%field_desc(n_fields), op%block_buffer(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + do i_field = 1, n_fields + field_global_size = field_sizes(i_field) + ! block distribution: field_global_size rows over num_procs processes (total size invariant) + field_local_rows = int(field_global_size / int(num_procs, psb_lpk_), psb_ipk_) + if (int(my_rank, psb_lpk_) < mod(field_global_size, int(num_procs, psb_lpk_))) & + & field_local_rows = field_local_rows + 1 + call psb_cdall(context, op%field_desc(i_field), info, nl=field_local_rows) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdall'); return + end if + end do + end subroutine psb_c_nest_op_init + + ! ins: accumulate the triplets into block (block_row,block_col) and register the + ! columns (field block_col index space) into that descriptor's union halo + subroutine psb_c_nest_op_ins(op, block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info) + class(psb_c_nest_matrix), intent(inout) :: op + integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + complex(psb_spk_), intent(in) :: entry_vals(:) + integer(psb_ipk_), intent(out) :: info + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_op_ins' + + if (op%assembled) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='operator already assembled'); return + end if + if (block_row < 1 .or. block_row > op%n_fields .or. & + & block_col < 1 .or. block_col > op%n_fields) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='block index out of range'); return + end if + if (n_entries <= 0) return + + call block_buffer_append(op%block_buffer(block_row,block_col), n_entries, & + & entry_rows, entry_cols, entry_vals, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + ! the columns of block (block_row,block_col) live in field block_col -> + ! register their indices into that descriptor's union halo + ! (this also applies when block_col == block_row) + call psb_cdins(n_entries, entry_cols(1:n_entries), op%field_desc(block_col), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins'); return + end if + end subroutine psb_c_nest_op_ins + + ! asb: assemble the descriptors, build the blocks, compose the global + ! descriptor, set up the operator and wrap it into a_glob. + ! The optional type ('CSR'/'CSC'/'COO', default 'CSR') or mold (any + ! class extending psb_c_base_sparse_mat, e.g. the psb_ext ELL/HLL or + ! the psb_cuda device formats) selects the storage format of the blocks. + subroutine psb_c_nest_op_asb(op, info, type, mold) + class(psb_c_nest_matrix), intent(inout), target :: op + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + + type(psb_c_nest_base_mat) :: nest_operator + integer(psb_ipk_) :: n_fields, i_field, j_field + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_op_asb' + n_fields = op%n_fields + + ! 1) assemble the per-field descriptors (with the union halo accumulated in ins) + do i_field = 1, n_fields + call psb_cdasb(op%field_desc(i_field), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb'); return + end if + end do + + ! 2) build the local blocks (generally rectangular) from the triplets + op%block_storage%nrblocks = n_fields + op%block_storage%ncblocks = n_fields + allocate(op%block_storage%mats(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do j_field = 1, n_fields + do i_field = 1, n_fields + if (op%block_buffer(i_field,j_field)%n_entries > 0) then + call psb_c_nest_rect_block(op%block_storage%mats(i_field,j_field), & + & op%block_buffer(i_field,j_field)%n_entries, & + & op%block_buffer(i_field,j_field)%entry_rows, & + & op%block_buffer(i_field,j_field)%entry_cols, & + & op%block_buffer(i_field,j_field)%entry_vals, & + & op%field_desc(i_field), op%field_desc(j_field), info, & + & type=type, mold=mold) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='rect_block'); return + end if + end if + end do + end do + + ! 3) descriptor grid: descs(i,j) = descriptor of field j + op%grid_desc%nrblocks = n_fields + op%grid_desc%ncblocks = n_fields + allocate(op%grid_desc%descs(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do j_field = 1, n_fields + do i_field = 1, n_fields + call op%field_desc(j_field)%clone(op%grid_desc%descs(i_field,j_field), info) + end do + end do + + ! 4) composed global descriptor + operator setup + call psb_cd_nest_compose(op%grid_desc, op%desc_glob, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='cd_nest_compose'); return + end if + call psb_c_nest_base_setup(nest_operator, op%block_storage, op%grid_desc, op%desc_glob, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='nest_base_setup'); return + end if + + ! 5) wrap into the standard matrix object (the pointers keep pointing at op%*) + allocate(op%a_glob%a, source=nest_operator, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call op%a_glob%set_nrows(op%desc_glob%get_local_rows()) + call op%a_glob%set_ncols(op%desc_glob%get_local_cols()) + call op%a_glob%set_asb() + + ! 6) the triplet buffers are no longer needed + do j_field = 1, n_fields + do i_field = 1, n_fields + call block_buffer_free(op%block_buffer(i_field,j_field)) + end do + end do + op%assembled = .true. + end subroutine psb_c_nest_op_asb + + ! free: release everything + subroutine psb_c_nest_op_free(op, info) + class(psb_c_nest_matrix), intent(inout) :: op + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field, j_field, local_info + + info = psb_success_ + if (allocated(op%block_buffer)) then + do j_field = 1, size(op%block_buffer,2) + do i_field = 1, size(op%block_buffer,1) + call block_buffer_free(op%block_buffer(i_field,j_field)) + end do + end do + deallocate(op%block_buffer, stat=local_info) + end if + if (op%assembled) then + call op%a_glob%free() + call op%desc_glob%free(local_info) + call op%grid_desc%free(local_info) + end if + if (allocated(op%field_desc)) then + do i_field = 1, size(op%field_desc) + call op%field_desc(i_field)%free(local_info) + end do + deallocate(op%field_desc, stat=local_info) + end if + op%n_fields = 0 + op%assembled = .false. + end subroutine psb_c_nest_op_free + + ! get_owned_rows: GLOBAL indices (in the field index space, 1..field size) + ! of the rows of field i_field owned by this process. This is the list of + ! rows the process is expected to insert through ins: + ! + ! my_rows = nested_matrix%get_owned_rows(1) + ! do k = 1, size(my_rows) + ! global_row = my_rows(k) + ! ... + ! + ! An empty array is returned for an out-of-range field index. + function psb_c_nest_op_get_owned_rows(op, i_field) result(owned_global_rows) + class(psb_c_nest_matrix), intent(in) :: op + integer(psb_ipk_), intent(in) :: i_field + integer(psb_lpk_), allocatable :: owned_global_rows(:) + + if ((i_field < 1) .or. (i_field > op%n_fields) .or. & + & (.not. allocated(op%field_desc))) then + allocate(owned_global_rows(0)) + return + end if + owned_global_rows = op%field_desc(i_field)%get_global_indices(owned=.true.) + end function psb_c_nest_op_get_owned_rows + + ! get_owned_row_count: how many rows of field i_field this process owns + function psb_c_nest_op_get_owned_row_count(op, i_field) result(owned_row_count) + class(psb_c_nest_matrix), intent(in) :: op + integer(psb_ipk_), intent(in) :: i_field + integer(psb_ipk_) :: owned_row_count + + owned_row_count = 0 + if ((i_field < 1) .or. (i_field > op%n_fields) .or. & + & (.not. allocated(op%field_desc))) return + owned_row_count = op%field_desc(i_field)%get_local_rows() + end function psb_c_nest_op_get_owned_row_count + + !----------------------------------------------------------------- + ! private helpers: growing triplet buffer + !----------------------------------------------------------------- + subroutine block_buffer_append(buffer, n_entries, entry_rows, entry_cols, entry_vals, info) + type(psb_c_nest_block_buffer), intent(inout) :: buffer + integer(psb_ipk_), intent(in) :: n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + complex(psb_spk_), intent(in) :: entry_vals(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: required_size + + info = psb_success_ + required_size = buffer%n_entries + n_entries + call ensure_capacity_lpk(buffer%entry_rows, required_size, info); if (info /= 0) return + call ensure_capacity_lpk(buffer%entry_cols, required_size, info); if (info /= 0) return + call ensure_capacity_val(buffer%entry_vals, required_size, info); if (info /= 0) return + buffer%entry_rows(buffer%n_entries+1:required_size) = entry_rows(1:n_entries) + buffer%entry_cols(buffer%n_entries+1:required_size) = entry_cols(1:n_entries) + buffer%entry_vals(buffer%n_entries+1:required_size) = entry_vals(1:n_entries) + buffer%n_entries = required_size + end subroutine block_buffer_append + + subroutine ensure_capacity_lpk(array, required_size, info) + integer(psb_lpk_), allocatable, intent(inout) :: array(:) + integer(psb_ipk_), intent(in) :: required_size + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable :: grown(:) + integer(psb_ipk_) :: capacity + + info = 0 + if (.not. allocated(array)) then + allocate(array(max(required_size,16)), stat=info); return + end if + capacity = size(array) + if (required_size <= capacity) return + allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return + grown(1:capacity) = array(1:capacity) + call move_alloc(grown, array) + end subroutine ensure_capacity_lpk + + subroutine ensure_capacity_val(array, required_size, info) + complex(psb_spk_), allocatable, intent(inout) :: array(:) + integer(psb_ipk_), intent(in) :: required_size + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), allocatable :: grown(:) + integer(psb_ipk_) :: capacity + + info = 0 + if (.not. allocated(array)) then + allocate(array(max(required_size,16)), stat=info); return + end if + capacity = size(array) + if (required_size <= capacity) return + allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return + grown(1:capacity) = array(1:capacity) + call move_alloc(grown, array) + end subroutine ensure_capacity_val + + subroutine block_buffer_free(buffer) + type(psb_c_nest_block_buffer), intent(inout) :: buffer + if (allocated(buffer%entry_rows)) deallocate(buffer%entry_rows) + if (allocated(buffer%entry_cols)) deallocate(buffer%entry_cols) + if (allocated(buffer%entry_vals)) deallocate(buffer%entry_vals) + buffer%n_entries = 0 + end subroutine block_buffer_free + +end module psb_c_nest_builder_mod diff --git a/base/modules/tools/psb_c_nest_tools_mod.F90 b/base/modules/tools/psb_c_nest_tools_mod.F90 new file mode 100644 index 000000000..da4e7f41c --- /dev/null +++ b/base/modules/tools/psb_c_nest_tools_mod.F90 @@ -0,0 +1,364 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Module: psb_c_nest_tools_mod +! Author: Simone Staccone (Stack-1) +! +! Nested-specific assembly wrappers for PSBLAS3 — double precision matrix and vector routines +! + +module psb_c_nest_tools_mod + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_spk_, psb_success_, psb_err_alloc_dealloc_, & + psb_err_invalid_input_, psb_err_from_subroutine_, & + psb_dupl_add_, psb_dupl_ovwrt_, psb_dupl_err_, psb_ctxt_type + use psb_error_mod, only : psb_errpush + use psb_c_tools_mod, only : psb_spall, psb_spins, psb_spasb, psb_spfree, psb_sprn, & + psb_geall, psb_geins, psb_geasb, psb_gefree + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_c_nest_mat_mod, only : psb_c_nest_sparse_mat + use psb_c_mat_mod, only : psb_cspmat_type + use psb_c_base_mat_mod, only : psb_c_coo_sparse_mat, psb_c_base_sparse_mat + use psb_desc_mod, only : psb_desc_type + implicit none + + private + + public :: psb_spall_nest, psb_spins_nest, psb_spasb_nest, psb_spfree_nest, psb_sprn_nest, & + psb_c_nest_rect_block + +contains + + ! Allocates all (nrblocks x ncblocks) sparse matrix blocks + ! and marks all as present. psb_spins_nest lazy-allocates individual + ! blocks on first insertion; call psb_spall_nest instead when the + ! full block structure is known up front. + + subroutine psb_spall_nest(a_nest, desc_nest, info, nnz) + type(psb_c_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: nnz + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spall_nest' + + a_nest%nrblocks = desc_nest%nrblocks + a_nest%ncblocks = desc_nest%ncblocks + + if (.not. allocated(a_nest%mats)) then + allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + return + end if + end if + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + local_info = psb_success_ + if (present(nnz)) then + call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, nnz=nnz) + else + call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + end if + if (local_info /= psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall') + return + end if + end do + end do + + end subroutine psb_spall_nest + + + ! Inserts nz entries into block (blk_i, blk_j) of the nested matrix. + ! The block is lazy-allocated on first insertion if psb_spall_nest + ! was not called first. + + subroutine psb_spins_nest(block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, a_nest, desc_nest, info) + integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + complex(psb_spk_), intent(in) :: entry_vals(:) + type(psb_c_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(inout) :: desc_nest + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nnz_estimate + character(len=20) :: name + + info = psb_success_ + name = 'psb_spins_nest' + + if (n_entries == 0) return + + if (block_row < 1 .or. block_row > a_nest%nrblocks .or. & + block_col < 1 .or. block_col > a_nest%ncblocks) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='invalid block indices') + return + end if + + if (.not. allocated(a_nest%mats)) then + allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + return + end if + end if + + if (.not. allocated(a_nest%mats(block_row, block_col)%a)) then + ! Estimate nnz: use n_entries + 50% buffer for future insertions + nnz_estimate = max(n_entries, 10) + n_entries / 2 + call psb_spall(a_nest%mats(block_row, block_col), & + desc_nest%descs(block_row, block_col), info, nnz=nnz_estimate) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall') + return + end if + end if + + call psb_spins(n_entries, entry_rows, entry_cols, entry_vals, a_nest%mats(block_row, block_col), & + desc_nest%descs(block_row, block_col), info) + if (info /= psb_success_) & + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spins') + + end subroutine psb_spins_nest + + ! Calls psb_spasb on all present block matrices. + ! Must be called after psb_cdasb_nest. + + subroutine psb_spasb_nest(a_nest, desc_nest, info, dupl) + type(psb_c_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(inout) :: desc_nest + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dupl + + integer(psb_ipk_) :: i_block_row, j_block_col, dupl_mode, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spasb_nest' + dupl_mode = psb_dupl_add_ + if (present(dupl)) dupl_mode = dupl + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + if (dupl_mode == psb_dupl_add_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_add_) + else if (dupl_mode == psb_dupl_ovwrt_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_ovwrt_) + else if (dupl_mode == psb_dupl_err_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_err_) + else + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info) + end if + if (local_info /= psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spasb') + return + end if + end if + end do + end do + + end subroutine psb_spasb_nest + + ! Calls psb_spfree on every present block, then deallocates the + ! mats array and resets nrblocks/ncblocks to 0. + + subroutine psb_spfree_nest(a_nest, desc_nest, info) + type(psb_c_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spfree_nest' + + if (allocated(a_nest%mats)) then + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + call psb_spfree(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + if (local_info /= psb_success_ .and. info == psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spfree') + end if + end if + end do + end do + deallocate(a_nest%mats, stat=local_info) + if (local_info /= 0 .and. info == psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + end if + end if + + a_nest%nrblocks = 0 + a_nest%ncblocks = 0 + + end subroutine psb_spfree_nest + + ! Calls psb_sprn on every present block matrix, resetting it to + ! the build state while preserving the sparsity pattern. + + subroutine psb_sprn_nest(a_nest, desc_nest, info, clear) + type(psb_c_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_sprn_nest' + + if (.not. allocated(a_nest%mats)) return + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + if (present(clear)) then + call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, clear=clear) + else + call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + end if + if (local_info /= psb_success_ .and. info == psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_sprn') + end if + end if + end do + end do + + end subroutine psb_sprn_nest + + + + ! psb_c_nest_rect_block + ! + ! Build a local GENERAL (possibly rectangular) block A(i,j) of a nested + ! operator, with rows in field i and columns in field j (field i /= field j, + ! |field i| /= |field j| allowed). Rows are localized against the field-i + ! (row) descriptor, columns against the field-j (column) descriptor — which + ! must already carry the union halo of column j (cdall + cdins(all column-j + ! blocks' columns) + cdasb). The result is a CSR block of shape + ! (field-i owned rows) x (field-j local cols incl. halo) + ! consumable directly by the nested csmv (psb_c_nest_base_mat). + ! + ! A single-descriptor psb_spall/psb_spasb cannot express row-field /= col-field + ! (it would force rows and columns into the same index space), hence the + ! explicit COO build with separate row/column localization. + ! + ! Arguments (this process's local contribution): + ! blk (out) the assembled block (CSR) + ! nz number of local entries + ! ia_glob(:) GLOBAL field-i row indices (owned by this process) + ! ja_glob(:) GLOBAL field-j column indices + ! val(:) values + ! desc_row field-i descriptor (rows) + ! desc_col field-j descriptor (columns, with union halo) + ! + subroutine psb_c_nest_rect_block(blk, nz, ia_glob, ja_glob, val, desc_row, desc_col, info, type, mold) + type(psb_cspmat_type), intent(out) :: blk + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia_glob(:), ja_glob(:) + complex(psb_spk_), intent(in) :: val(:) + type(psb_desc_type), intent(in) :: desc_row, desc_col + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: type ! base storage format (default 'CSR') + class(psb_c_base_sparse_mat), intent(in), optional :: mold ! any format, e.g. psb_ext ELL/HLL + + type(psb_c_coo_sparse_mat) :: coo_block + integer(psb_ipk_) :: k_entry, n_loc_rows, n_loc_cols, loc_row, loc_col + character(len=24) :: name + + info = psb_success_ + name = 'psb_c_nest_rect_block' + + n_loc_rows = desc_row%get_local_rows() ! owned rows of field i + n_loc_cols = desc_col%get_local_cols() ! field-j local cols (owned + halo) + + call coo_block%allocate(n_loc_rows, n_loc_cols, nz) + do k_entry = 1, nz + call desc_row%g2l(ia_glob(k_entry), loc_row, info) + if (info /= 0 .or. loc_row < 1 .or. loc_row > n_loc_rows) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='row not owned / not localizable') + return + end if + call desc_col%g2l(ja_glob(k_entry), loc_col, info) + if (info /= 0 .or. loc_col < 1 .or. loc_col > n_loc_cols) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='column not in field-j descriptor (missing from union halo)') + return + end if + coo_block%ia(k_entry) = loc_row + coo_block%ja(k_entry) = loc_col + coo_block%val(k_entry) = val(k_entry) + end do + call coo_block%set_nzeros(nz) + call coo_block%set_dupl(psb_dupl_add_) + call coo_block%fix(info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix'); return + end if + call blk%mv_from(coo_block) + if (present(mold)) then + call blk%cscnv(info, mold=mold) + else if (present(type)) then + call blk%cscnv(info, type=type) + else + call blk%cscnv(info, type='CSR') + end if + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='cscnv'); return + end if + end subroutine psb_c_nest_rect_block + +end module psb_c_nest_tools_mod diff --git a/base/modules/tools/psb_d_nest_builder_mod.F90 b/base/modules/tools/psb_d_nest_builder_mod.F90 index 345c8d02a..fcbc5ed5a 100644 --- a/base/modules/tools/psb_d_nest_builder_mod.F90 +++ b/base/modules/tools/psb_d_nest_builder_mod.F90 @@ -360,7 +360,7 @@ contains required_size = buffer%n_entries + n_entries call ensure_capacity_lpk(buffer%entry_rows, required_size, info); if (info /= 0) return call ensure_capacity_lpk(buffer%entry_cols, required_size, info); if (info /= 0) return - call ensure_capacity_dpk(buffer%entry_vals, required_size, info); if (info /= 0) return + call ensure_capacity_val(buffer%entry_vals, required_size, info); if (info /= 0) return buffer%entry_rows(buffer%n_entries+1:required_size) = entry_rows(1:n_entries) buffer%entry_cols(buffer%n_entries+1:required_size) = entry_cols(1:n_entries) buffer%entry_vals(buffer%n_entries+1:required_size) = entry_vals(1:n_entries) @@ -385,7 +385,7 @@ contains call move_alloc(grown, array) end subroutine ensure_capacity_lpk - subroutine ensure_capacity_dpk(array, required_size, info) + subroutine ensure_capacity_val(array, required_size, info) real(psb_dpk_), allocatable, intent(inout) :: array(:) integer(psb_ipk_), intent(in) :: required_size integer(psb_ipk_), intent(out) :: info @@ -401,7 +401,7 @@ contains allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return grown(1:capacity) = array(1:capacity) call move_alloc(grown, array) - end subroutine ensure_capacity_dpk + end subroutine ensure_capacity_val subroutine block_buffer_free(buffer) type(psb_d_nest_block_buffer), intent(inout) :: buffer diff --git a/base/modules/tools/psb_s_nest_builder_mod.F90 b/base/modules/tools/psb_s_nest_builder_mod.F90 new file mode 100644 index 000000000..59686b3f2 --- /dev/null +++ b/base/modules/tools/psb_s_nest_builder_mod.F90 @@ -0,0 +1,414 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_s_nest_builder_mod.F90 +! +! Module: psb_s_nest_builder_mod +! Author: Simone Staccone (Stack-1) +! +! User-friendly frontend to build a nested (MATNEST) operator without manually +! managing per-field descriptors, the union halo, composition and setup. +! +! All the boilerplate (identical for every nested operator) is hidden behind a +! single type, psb_s_nest_matrix, with the usual PSBLAS init/ins/asb pattern: +! +! type(psb_s_nest_matrix) :: nested_matrix +! call nested_matrix%init(ctxt, [n1, n2], info) ! 2 fields of global size n1, n2 +! call nested_matrix%ins(1,1, n, rows, cols, vals, info) ! values of block (1,1) = A +! call nested_matrix%ins(1,2, n, rows, cols, vals, info) ! values of block (1,2) = B^T +! call nested_matrix%ins(2,1, n, rows, cols, vals, info) ! values of block (2,1) = B +! ... ! (absent blocks = not inserted) +! call nested_matrix%asb(info) ! assemble: builds a_glob, desc_glob +! +! ! from here on nested_matrix%a_glob and nested_matrix%desc_glob are an +! ! ordinary distributed matrix/descriptor: +! call psb_geall(x, nested_matrix%desc_glob, info) +! call psb_krylov('CG', nested_matrix%a_glob, prec, b, x, eps, nested_matrix%desc_glob, info, ...) +! +! Indices: in ins(block_row, block_col, ...) the rows live in the index space of +! field block_row, the columns in the index space of field block_col (GLOBAL +! field indices, 1..field_size). Each process inserts only the rows it owns +! (PSBLAS convention). Off-diagonal blocks may be rectangular. +! +! NOTE: after asb the object holds consistent internal pointers (a_glob%a points +! to block_storage / grid_desc): do not copy/move the object after assembly. +! +module psb_s_nest_builder_mod + use psb_const_mod + use psb_error_mod, only : psb_errpush + use psb_penv_mod, only : psb_ctxt_type, psb_info + use psb_desc_mod, only : psb_desc_type + use psb_s_mat_mod, only : psb_sspmat_type + use psb_s_base_mat_mod, only : psb_s_base_sparse_mat + use psb_cd_tools_mod, only : psb_cdall, psb_cdins, psb_cdasb + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_s_nest_mat_mod, only : psb_s_nest_sparse_mat + use psb_s_nest_base_mat_mod, only : psb_s_nest_base_mat, psb_s_nest_base_setup + use psb_cd_nest_tools_mod, only : psb_cd_nest_compose + use psb_s_nest_tools_mod, only : psb_s_nest_rect_block + implicit none + + ! growing triplet buffer for a single block + type :: psb_s_nest_block_buffer + integer(psb_ipk_) :: n_entries = 0 + integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:) + real(psb_spk_), allocatable :: entry_vals(:) + end type psb_s_nest_block_buffer + + type :: psb_s_nest_matrix + type(psb_ctxt_type) :: context + integer(psb_ipk_) :: n_fields = 0 + logical :: assembled = .false. + ! construction state + type(psb_desc_type), allocatable :: field_desc(:) ! one descriptor per field + type(psb_s_nest_block_buffer), allocatable :: block_buffer(:,:) ! triplets per block (i,j) + ! products (owned; the pointers in a_glob%a point in here) + type(psb_s_nest_sparse_mat) :: block_storage + type(psb_desc_nest_type) :: grid_desc + type(psb_sspmat_type) :: a_glob ! the matrix to hand to Krylov + type(psb_desc_type) :: desc_glob ! the global descriptor + contains + procedure, pass(op) :: init => psb_s_nest_op_init + procedure, pass(op) :: ins => psb_s_nest_op_ins + procedure, pass(op) :: asb => psb_s_nest_op_asb + procedure, pass(op) :: free => psb_s_nest_op_free + ! user-friendly queries on the field row distribution (no descriptor + ! jargon needed: these replace field_desc(i)%get_local_rows() / %l2g(...)) + procedure, pass(op) :: get_owned_rows => psb_s_nest_op_get_owned_rows + procedure, pass(op) :: get_owned_row_count => psb_s_nest_op_get_owned_row_count + end type psb_s_nest_matrix + + private + public :: psb_s_nest_matrix + +contains + + ! init: create one descriptor per field (block distribution from the global sizes) + subroutine psb_s_nest_op_init(op, context, field_sizes, info) + class(psb_s_nest_matrix), intent(inout) :: op + type(psb_ctxt_type), intent(in) :: context + integer(psb_lpk_), intent(in) :: field_sizes(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: my_rank, num_procs, n_fields, i_field, field_local_rows + integer(psb_lpk_) :: field_global_size + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_op_init' + + call psb_info(context, my_rank, num_procs) + n_fields = size(field_sizes) + op%context = context + op%n_fields = n_fields + op%assembled = .false. + + allocate(op%field_desc(n_fields), op%block_buffer(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + do i_field = 1, n_fields + field_global_size = field_sizes(i_field) + ! block distribution: field_global_size rows over num_procs processes (total size invariant) + field_local_rows = int(field_global_size / int(num_procs, psb_lpk_), psb_ipk_) + if (int(my_rank, psb_lpk_) < mod(field_global_size, int(num_procs, psb_lpk_))) & + & field_local_rows = field_local_rows + 1 + call psb_cdall(context, op%field_desc(i_field), info, nl=field_local_rows) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdall'); return + end if + end do + end subroutine psb_s_nest_op_init + + ! ins: accumulate the triplets into block (block_row,block_col) and register the + ! columns (field block_col index space) into that descriptor's union halo + subroutine psb_s_nest_op_ins(op, block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info) + class(psb_s_nest_matrix), intent(inout) :: op + integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + real(psb_spk_), intent(in) :: entry_vals(:) + integer(psb_ipk_), intent(out) :: info + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_op_ins' + + if (op%assembled) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='operator already assembled'); return + end if + if (block_row < 1 .or. block_row > op%n_fields .or. & + & block_col < 1 .or. block_col > op%n_fields) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='block index out of range'); return + end if + if (n_entries <= 0) return + + call block_buffer_append(op%block_buffer(block_row,block_col), n_entries, & + & entry_rows, entry_cols, entry_vals, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + ! the columns of block (block_row,block_col) live in field block_col -> + ! register their indices into that descriptor's union halo + ! (this also applies when block_col == block_row) + call psb_cdins(n_entries, entry_cols(1:n_entries), op%field_desc(block_col), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins'); return + end if + end subroutine psb_s_nest_op_ins + + ! asb: assemble the descriptors, build the blocks, compose the global + ! descriptor, set up the operator and wrap it into a_glob. + ! The optional type ('CSR'/'CSC'/'COO', default 'CSR') or mold (any + ! class extending psb_s_base_sparse_mat, e.g. the psb_ext ELL/HLL or + ! the psb_cuda device formats) selects the storage format of the blocks. + subroutine psb_s_nest_op_asb(op, info, type, mold) + class(psb_s_nest_matrix), intent(inout), target :: op + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + + type(psb_s_nest_base_mat) :: nest_operator + integer(psb_ipk_) :: n_fields, i_field, j_field + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_op_asb' + n_fields = op%n_fields + + ! 1) assemble the per-field descriptors (with the union halo accumulated in ins) + do i_field = 1, n_fields + call psb_cdasb(op%field_desc(i_field), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb'); return + end if + end do + + ! 2) build the local blocks (generally rectangular) from the triplets + op%block_storage%nrblocks = n_fields + op%block_storage%ncblocks = n_fields + allocate(op%block_storage%mats(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do j_field = 1, n_fields + do i_field = 1, n_fields + if (op%block_buffer(i_field,j_field)%n_entries > 0) then + call psb_s_nest_rect_block(op%block_storage%mats(i_field,j_field), & + & op%block_buffer(i_field,j_field)%n_entries, & + & op%block_buffer(i_field,j_field)%entry_rows, & + & op%block_buffer(i_field,j_field)%entry_cols, & + & op%block_buffer(i_field,j_field)%entry_vals, & + & op%field_desc(i_field), op%field_desc(j_field), info, & + & type=type, mold=mold) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='rect_block'); return + end if + end if + end do + end do + + ! 3) descriptor grid: descs(i,j) = descriptor of field j + op%grid_desc%nrblocks = n_fields + op%grid_desc%ncblocks = n_fields + allocate(op%grid_desc%descs(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do j_field = 1, n_fields + do i_field = 1, n_fields + call op%field_desc(j_field)%clone(op%grid_desc%descs(i_field,j_field), info) + end do + end do + + ! 4) composed global descriptor + operator setup + call psb_cd_nest_compose(op%grid_desc, op%desc_glob, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='cd_nest_compose'); return + end if + call psb_s_nest_base_setup(nest_operator, op%block_storage, op%grid_desc, op%desc_glob, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='nest_base_setup'); return + end if + + ! 5) wrap into the standard matrix object (the pointers keep pointing at op%*) + allocate(op%a_glob%a, source=nest_operator, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call op%a_glob%set_nrows(op%desc_glob%get_local_rows()) + call op%a_glob%set_ncols(op%desc_glob%get_local_cols()) + call op%a_glob%set_asb() + + ! 6) the triplet buffers are no longer needed + do j_field = 1, n_fields + do i_field = 1, n_fields + call block_buffer_free(op%block_buffer(i_field,j_field)) + end do + end do + op%assembled = .true. + end subroutine psb_s_nest_op_asb + + ! free: release everything + subroutine psb_s_nest_op_free(op, info) + class(psb_s_nest_matrix), intent(inout) :: op + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field, j_field, local_info + + info = psb_success_ + if (allocated(op%block_buffer)) then + do j_field = 1, size(op%block_buffer,2) + do i_field = 1, size(op%block_buffer,1) + call block_buffer_free(op%block_buffer(i_field,j_field)) + end do + end do + deallocate(op%block_buffer, stat=local_info) + end if + if (op%assembled) then + call op%a_glob%free() + call op%desc_glob%free(local_info) + call op%grid_desc%free(local_info) + end if + if (allocated(op%field_desc)) then + do i_field = 1, size(op%field_desc) + call op%field_desc(i_field)%free(local_info) + end do + deallocate(op%field_desc, stat=local_info) + end if + op%n_fields = 0 + op%assembled = .false. + end subroutine psb_s_nest_op_free + + ! get_owned_rows: GLOBAL indices (in the field index space, 1..field size) + ! of the rows of field i_field owned by this process. This is the list of + ! rows the process is expected to insert through ins: + ! + ! my_rows = nested_matrix%get_owned_rows(1) + ! do k = 1, size(my_rows) + ! global_row = my_rows(k) + ! ... + ! + ! An empty array is returned for an out-of-range field index. + function psb_s_nest_op_get_owned_rows(op, i_field) result(owned_global_rows) + class(psb_s_nest_matrix), intent(in) :: op + integer(psb_ipk_), intent(in) :: i_field + integer(psb_lpk_), allocatable :: owned_global_rows(:) + + if ((i_field < 1) .or. (i_field > op%n_fields) .or. & + & (.not. allocated(op%field_desc))) then + allocate(owned_global_rows(0)) + return + end if + owned_global_rows = op%field_desc(i_field)%get_global_indices(owned=.true.) + end function psb_s_nest_op_get_owned_rows + + ! get_owned_row_count: how many rows of field i_field this process owns + function psb_s_nest_op_get_owned_row_count(op, i_field) result(owned_row_count) + class(psb_s_nest_matrix), intent(in) :: op + integer(psb_ipk_), intent(in) :: i_field + integer(psb_ipk_) :: owned_row_count + + owned_row_count = 0 + if ((i_field < 1) .or. (i_field > op%n_fields) .or. & + & (.not. allocated(op%field_desc))) return + owned_row_count = op%field_desc(i_field)%get_local_rows() + end function psb_s_nest_op_get_owned_row_count + + !----------------------------------------------------------------- + ! private helpers: growing triplet buffer + !----------------------------------------------------------------- + subroutine block_buffer_append(buffer, n_entries, entry_rows, entry_cols, entry_vals, info) + type(psb_s_nest_block_buffer), intent(inout) :: buffer + integer(psb_ipk_), intent(in) :: n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + real(psb_spk_), intent(in) :: entry_vals(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: required_size + + info = psb_success_ + required_size = buffer%n_entries + n_entries + call ensure_capacity_lpk(buffer%entry_rows, required_size, info); if (info /= 0) return + call ensure_capacity_lpk(buffer%entry_cols, required_size, info); if (info /= 0) return + call ensure_capacity_val(buffer%entry_vals, required_size, info); if (info /= 0) return + buffer%entry_rows(buffer%n_entries+1:required_size) = entry_rows(1:n_entries) + buffer%entry_cols(buffer%n_entries+1:required_size) = entry_cols(1:n_entries) + buffer%entry_vals(buffer%n_entries+1:required_size) = entry_vals(1:n_entries) + buffer%n_entries = required_size + end subroutine block_buffer_append + + subroutine ensure_capacity_lpk(array, required_size, info) + integer(psb_lpk_), allocatable, intent(inout) :: array(:) + integer(psb_ipk_), intent(in) :: required_size + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable :: grown(:) + integer(psb_ipk_) :: capacity + + info = 0 + if (.not. allocated(array)) then + allocate(array(max(required_size,16)), stat=info); return + end if + capacity = size(array) + if (required_size <= capacity) return + allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return + grown(1:capacity) = array(1:capacity) + call move_alloc(grown, array) + end subroutine ensure_capacity_lpk + + subroutine ensure_capacity_val(array, required_size, info) + real(psb_spk_), allocatable, intent(inout) :: array(:) + integer(psb_ipk_), intent(in) :: required_size + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), allocatable :: grown(:) + integer(psb_ipk_) :: capacity + + info = 0 + if (.not. allocated(array)) then + allocate(array(max(required_size,16)), stat=info); return + end if + capacity = size(array) + if (required_size <= capacity) return + allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return + grown(1:capacity) = array(1:capacity) + call move_alloc(grown, array) + end subroutine ensure_capacity_val + + subroutine block_buffer_free(buffer) + type(psb_s_nest_block_buffer), intent(inout) :: buffer + if (allocated(buffer%entry_rows)) deallocate(buffer%entry_rows) + if (allocated(buffer%entry_cols)) deallocate(buffer%entry_cols) + if (allocated(buffer%entry_vals)) deallocate(buffer%entry_vals) + buffer%n_entries = 0 + end subroutine block_buffer_free + +end module psb_s_nest_builder_mod diff --git a/base/modules/tools/psb_s_nest_tools_mod.F90 b/base/modules/tools/psb_s_nest_tools_mod.F90 new file mode 100644 index 000000000..c9681942d --- /dev/null +++ b/base/modules/tools/psb_s_nest_tools_mod.F90 @@ -0,0 +1,364 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Module: psb_s_nest_tools_mod +! Author: Simone Staccone (Stack-1) +! +! Nested-specific assembly wrappers for PSBLAS3 — double precision matrix and vector routines +! + +module psb_s_nest_tools_mod + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_spk_, psb_success_, psb_err_alloc_dealloc_, & + psb_err_invalid_input_, psb_err_from_subroutine_, & + psb_dupl_add_, psb_dupl_ovwrt_, psb_dupl_err_, psb_ctxt_type + use psb_error_mod, only : psb_errpush + use psb_s_tools_mod, only : psb_spall, psb_spins, psb_spasb, psb_spfree, psb_sprn, & + psb_geall, psb_geins, psb_geasb, psb_gefree + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_s_nest_mat_mod, only : psb_s_nest_sparse_mat + use psb_s_mat_mod, only : psb_sspmat_type + use psb_s_base_mat_mod, only : psb_s_coo_sparse_mat, psb_s_base_sparse_mat + use psb_desc_mod, only : psb_desc_type + implicit none + + private + + public :: psb_spall_nest, psb_spins_nest, psb_spasb_nest, psb_spfree_nest, psb_sprn_nest, & + psb_s_nest_rect_block + +contains + + ! Allocates all (nrblocks x ncblocks) sparse matrix blocks + ! and marks all as present. psb_spins_nest lazy-allocates individual + ! blocks on first insertion; call psb_spall_nest instead when the + ! full block structure is known up front. + + subroutine psb_spall_nest(a_nest, desc_nest, info, nnz) + type(psb_s_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: nnz + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spall_nest' + + a_nest%nrblocks = desc_nest%nrblocks + a_nest%ncblocks = desc_nest%ncblocks + + if (.not. allocated(a_nest%mats)) then + allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + return + end if + end if + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + local_info = psb_success_ + if (present(nnz)) then + call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, nnz=nnz) + else + call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + end if + if (local_info /= psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall') + return + end if + end do + end do + + end subroutine psb_spall_nest + + + ! Inserts nz entries into block (blk_i, blk_j) of the nested matrix. + ! The block is lazy-allocated on first insertion if psb_spall_nest + ! was not called first. + + subroutine psb_spins_nest(block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, a_nest, desc_nest, info) + integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + real(psb_spk_), intent(in) :: entry_vals(:) + type(psb_s_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(inout) :: desc_nest + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nnz_estimate + character(len=20) :: name + + info = psb_success_ + name = 'psb_spins_nest' + + if (n_entries == 0) return + + if (block_row < 1 .or. block_row > a_nest%nrblocks .or. & + block_col < 1 .or. block_col > a_nest%ncblocks) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='invalid block indices') + return + end if + + if (.not. allocated(a_nest%mats)) then + allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + return + end if + end if + + if (.not. allocated(a_nest%mats(block_row, block_col)%a)) then + ! Estimate nnz: use n_entries + 50% buffer for future insertions + nnz_estimate = max(n_entries, 10) + n_entries / 2 + call psb_spall(a_nest%mats(block_row, block_col), & + desc_nest%descs(block_row, block_col), info, nnz=nnz_estimate) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall') + return + end if + end if + + call psb_spins(n_entries, entry_rows, entry_cols, entry_vals, a_nest%mats(block_row, block_col), & + desc_nest%descs(block_row, block_col), info) + if (info /= psb_success_) & + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spins') + + end subroutine psb_spins_nest + + ! Calls psb_spasb on all present block matrices. + ! Must be called after psb_cdasb_nest. + + subroutine psb_spasb_nest(a_nest, desc_nest, info, dupl) + type(psb_s_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(inout) :: desc_nest + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dupl + + integer(psb_ipk_) :: i_block_row, j_block_col, dupl_mode, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spasb_nest' + dupl_mode = psb_dupl_add_ + if (present(dupl)) dupl_mode = dupl + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + if (dupl_mode == psb_dupl_add_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_add_) + else if (dupl_mode == psb_dupl_ovwrt_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_ovwrt_) + else if (dupl_mode == psb_dupl_err_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_err_) + else + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info) + end if + if (local_info /= psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spasb') + return + end if + end if + end do + end do + + end subroutine psb_spasb_nest + + ! Calls psb_spfree on every present block, then deallocates the + ! mats array and resets nrblocks/ncblocks to 0. + + subroutine psb_spfree_nest(a_nest, desc_nest, info) + type(psb_s_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spfree_nest' + + if (allocated(a_nest%mats)) then + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + call psb_spfree(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + if (local_info /= psb_success_ .and. info == psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spfree') + end if + end if + end do + end do + deallocate(a_nest%mats, stat=local_info) + if (local_info /= 0 .and. info == psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + end if + end if + + a_nest%nrblocks = 0 + a_nest%ncblocks = 0 + + end subroutine psb_spfree_nest + + ! Calls psb_sprn on every present block matrix, resetting it to + ! the build state while preserving the sparsity pattern. + + subroutine psb_sprn_nest(a_nest, desc_nest, info, clear) + type(psb_s_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_sprn_nest' + + if (.not. allocated(a_nest%mats)) return + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + if (present(clear)) then + call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, clear=clear) + else + call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + end if + if (local_info /= psb_success_ .and. info == psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_sprn') + end if + end if + end do + end do + + end subroutine psb_sprn_nest + + + + ! psb_s_nest_rect_block + ! + ! Build a local GENERAL (possibly rectangular) block A(i,j) of a nested + ! operator, with rows in field i and columns in field j (field i /= field j, + ! |field i| /= |field j| allowed). Rows are localized against the field-i + ! (row) descriptor, columns against the field-j (column) descriptor — which + ! must already carry the union halo of column j (cdall + cdins(all column-j + ! blocks' columns) + cdasb). The result is a CSR block of shape + ! (field-i owned rows) x (field-j local cols incl. halo) + ! consumable directly by the nested csmv (psb_s_nest_base_mat). + ! + ! A single-descriptor psb_spall/psb_spasb cannot express row-field /= col-field + ! (it would force rows and columns into the same index space), hence the + ! explicit COO build with separate row/column localization. + ! + ! Arguments (this process's local contribution): + ! blk (out) the assembled block (CSR) + ! nz number of local entries + ! ia_glob(:) GLOBAL field-i row indices (owned by this process) + ! ja_glob(:) GLOBAL field-j column indices + ! val(:) values + ! desc_row field-i descriptor (rows) + ! desc_col field-j descriptor (columns, with union halo) + ! + subroutine psb_s_nest_rect_block(blk, nz, ia_glob, ja_glob, val, desc_row, desc_col, info, type, mold) + type(psb_sspmat_type), intent(out) :: blk + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia_glob(:), ja_glob(:) + real(psb_spk_), intent(in) :: val(:) + type(psb_desc_type), intent(in) :: desc_row, desc_col + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: type ! base storage format (default 'CSR') + class(psb_s_base_sparse_mat), intent(in), optional :: mold ! any format, e.g. psb_ext ELL/HLL + + type(psb_s_coo_sparse_mat) :: coo_block + integer(psb_ipk_) :: k_entry, n_loc_rows, n_loc_cols, loc_row, loc_col + character(len=24) :: name + + info = psb_success_ + name = 'psb_s_nest_rect_block' + + n_loc_rows = desc_row%get_local_rows() ! owned rows of field i + n_loc_cols = desc_col%get_local_cols() ! field-j local cols (owned + halo) + + call coo_block%allocate(n_loc_rows, n_loc_cols, nz) + do k_entry = 1, nz + call desc_row%g2l(ia_glob(k_entry), loc_row, info) + if (info /= 0 .or. loc_row < 1 .or. loc_row > n_loc_rows) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='row not owned / not localizable') + return + end if + call desc_col%g2l(ja_glob(k_entry), loc_col, info) + if (info /= 0 .or. loc_col < 1 .or. loc_col > n_loc_cols) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='column not in field-j descriptor (missing from union halo)') + return + end if + coo_block%ia(k_entry) = loc_row + coo_block%ja(k_entry) = loc_col + coo_block%val(k_entry) = val(k_entry) + end do + call coo_block%set_nzeros(nz) + call coo_block%set_dupl(psb_dupl_add_) + call coo_block%fix(info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix'); return + end if + call blk%mv_from(coo_block) + if (present(mold)) then + call blk%cscnv(info, mold=mold) + else if (present(type)) then + call blk%cscnv(info, type=type) + else + call blk%cscnv(info, type='CSR') + end if + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='cscnv'); return + end if + end subroutine psb_s_nest_rect_block + +end module psb_s_nest_tools_mod diff --git a/base/modules/tools/psb_z_nest_builder_mod.F90 b/base/modules/tools/psb_z_nest_builder_mod.F90 new file mode 100644 index 000000000..c2f92f9df --- /dev/null +++ b/base/modules/tools/psb_z_nest_builder_mod.F90 @@ -0,0 +1,414 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_z_nest_builder_mod.F90 +! +! Module: psb_z_nest_builder_mod +! Author: Simone Staccone (Stack-1) +! +! User-friendly frontend to build a nested (MATNEST) operator without manually +! managing per-field descriptors, the union halo, composition and setup. +! +! All the boilerplate (identical for every nested operator) is hidden behind a +! single type, psb_z_nest_matrix, with the usual PSBLAS init/ins/asb pattern: +! +! type(psb_z_nest_matrix) :: nested_matrix +! call nested_matrix%init(ctxt, [n1, n2], info) ! 2 fields of global size n1, n2 +! call nested_matrix%ins(1,1, n, rows, cols, vals, info) ! values of block (1,1) = A +! call nested_matrix%ins(1,2, n, rows, cols, vals, info) ! values of block (1,2) = B^T +! call nested_matrix%ins(2,1, n, rows, cols, vals, info) ! values of block (2,1) = B +! ... ! (absent blocks = not inserted) +! call nested_matrix%asb(info) ! assemble: builds a_glob, desc_glob +! +! ! from here on nested_matrix%a_glob and nested_matrix%desc_glob are an +! ! ordinary distributed matrix/descriptor: +! call psb_geall(x, nested_matrix%desc_glob, info) +! call psb_krylov('CG', nested_matrix%a_glob, prec, b, x, eps, nested_matrix%desc_glob, info, ...) +! +! Indices: in ins(block_row, block_col, ...) the rows live in the index space of +! field block_row, the columns in the index space of field block_col (GLOBAL +! field indices, 1..field_size). Each process inserts only the rows it owns +! (PSBLAS convention). Off-diagonal blocks may be rectangular. +! +! NOTE: after asb the object holds consistent internal pointers (a_glob%a points +! to block_storage / grid_desc): do not copy/move the object after assembly. +! +module psb_z_nest_builder_mod + use psb_const_mod + use psb_error_mod, only : psb_errpush + use psb_penv_mod, only : psb_ctxt_type, psb_info + use psb_desc_mod, only : psb_desc_type + use psb_z_mat_mod, only : psb_zspmat_type + use psb_z_base_mat_mod, only : psb_z_base_sparse_mat + use psb_cd_tools_mod, only : psb_cdall, psb_cdins, psb_cdasb + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_z_nest_mat_mod, only : psb_z_nest_sparse_mat + use psb_z_nest_base_mat_mod, only : psb_z_nest_base_mat, psb_z_nest_base_setup + use psb_cd_nest_tools_mod, only : psb_cd_nest_compose + use psb_z_nest_tools_mod, only : psb_z_nest_rect_block + implicit none + + ! growing triplet buffer for a single block + type :: psb_z_nest_block_buffer + integer(psb_ipk_) :: n_entries = 0 + integer(psb_lpk_), allocatable :: entry_rows(:), entry_cols(:) + complex(psb_dpk_), allocatable :: entry_vals(:) + end type psb_z_nest_block_buffer + + type :: psb_z_nest_matrix + type(psb_ctxt_type) :: context + integer(psb_ipk_) :: n_fields = 0 + logical :: assembled = .false. + ! construction state + type(psb_desc_type), allocatable :: field_desc(:) ! one descriptor per field + type(psb_z_nest_block_buffer), allocatable :: block_buffer(:,:) ! triplets per block (i,j) + ! products (owned; the pointers in a_glob%a point in here) + type(psb_z_nest_sparse_mat) :: block_storage + type(psb_desc_nest_type) :: grid_desc + type(psb_zspmat_type) :: a_glob ! the matrix to hand to Krylov + type(psb_desc_type) :: desc_glob ! the global descriptor + contains + procedure, pass(op) :: init => psb_z_nest_op_init + procedure, pass(op) :: ins => psb_z_nest_op_ins + procedure, pass(op) :: asb => psb_z_nest_op_asb + procedure, pass(op) :: free => psb_z_nest_op_free + ! user-friendly queries on the field row distribution (no descriptor + ! jargon needed: these replace field_desc(i)%get_local_rows() / %l2g(...)) + procedure, pass(op) :: get_owned_rows => psb_z_nest_op_get_owned_rows + procedure, pass(op) :: get_owned_row_count => psb_z_nest_op_get_owned_row_count + end type psb_z_nest_matrix + + private + public :: psb_z_nest_matrix + +contains + + ! init: create one descriptor per field (block distribution from the global sizes) + subroutine psb_z_nest_op_init(op, context, field_sizes, info) + class(psb_z_nest_matrix), intent(inout) :: op + type(psb_ctxt_type), intent(in) :: context + integer(psb_lpk_), intent(in) :: field_sizes(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: my_rank, num_procs, n_fields, i_field, field_local_rows + integer(psb_lpk_) :: field_global_size + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_op_init' + + call psb_info(context, my_rank, num_procs) + n_fields = size(field_sizes) + op%context = context + op%n_fields = n_fields + op%assembled = .false. + + allocate(op%field_desc(n_fields), op%block_buffer(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + do i_field = 1, n_fields + field_global_size = field_sizes(i_field) + ! block distribution: field_global_size rows over num_procs processes (total size invariant) + field_local_rows = int(field_global_size / int(num_procs, psb_lpk_), psb_ipk_) + if (int(my_rank, psb_lpk_) < mod(field_global_size, int(num_procs, psb_lpk_))) & + & field_local_rows = field_local_rows + 1 + call psb_cdall(context, op%field_desc(i_field), info, nl=field_local_rows) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdall'); return + end if + end do + end subroutine psb_z_nest_op_init + + ! ins: accumulate the triplets into block (block_row,block_col) and register the + ! columns (field block_col index space) into that descriptor's union halo + subroutine psb_z_nest_op_ins(op, block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, info) + class(psb_z_nest_matrix), intent(inout) :: op + integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + complex(psb_dpk_), intent(in) :: entry_vals(:) + integer(psb_ipk_), intent(out) :: info + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_op_ins' + + if (op%assembled) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='operator already assembled'); return + end if + if (block_row < 1 .or. block_row > op%n_fields .or. & + & block_col < 1 .or. block_col > op%n_fields) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='block index out of range'); return + end if + if (n_entries <= 0) return + + call block_buffer_append(op%block_buffer(block_row,block_col), n_entries, & + & entry_rows, entry_cols, entry_vals, info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + + ! the columns of block (block_row,block_col) live in field block_col -> + ! register their indices into that descriptor's union halo + ! (this also applies when block_col == block_row) + call psb_cdins(n_entries, entry_cols(1:n_entries), op%field_desc(block_col), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdins'); return + end if + end subroutine psb_z_nest_op_ins + + ! asb: assemble the descriptors, build the blocks, compose the global + ! descriptor, set up the operator and wrap it into a_glob. + ! The optional type ('CSR'/'CSC'/'COO', default 'CSR') or mold (any + ! class extending psb_z_base_sparse_mat, e.g. the psb_ext ELL/HLL or + ! the psb_cuda device formats) selects the storage format of the blocks. + subroutine psb_z_nest_op_asb(op, info, type, mold) + class(psb_z_nest_matrix), intent(inout), target :: op + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + + type(psb_z_nest_base_mat) :: nest_operator + integer(psb_ipk_) :: n_fields, i_field, j_field + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_op_asb' + n_fields = op%n_fields + + ! 1) assemble the per-field descriptors (with the union halo accumulated in ins) + do i_field = 1, n_fields + call psb_cdasb(op%field_desc(i_field), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_cdasb'); return + end if + end do + + ! 2) build the local blocks (generally rectangular) from the triplets + op%block_storage%nrblocks = n_fields + op%block_storage%ncblocks = n_fields + allocate(op%block_storage%mats(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do j_field = 1, n_fields + do i_field = 1, n_fields + if (op%block_buffer(i_field,j_field)%n_entries > 0) then + call psb_z_nest_rect_block(op%block_storage%mats(i_field,j_field), & + & op%block_buffer(i_field,j_field)%n_entries, & + & op%block_buffer(i_field,j_field)%entry_rows, & + & op%block_buffer(i_field,j_field)%entry_cols, & + & op%block_buffer(i_field,j_field)%entry_vals, & + & op%field_desc(i_field), op%field_desc(j_field), info, & + & type=type, mold=mold) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='rect_block'); return + end if + end if + end do + end do + + ! 3) descriptor grid: descs(i,j) = descriptor of field j + op%grid_desc%nrblocks = n_fields + op%grid_desc%ncblocks = n_fields + allocate(op%grid_desc%descs(n_fields,n_fields), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + do j_field = 1, n_fields + do i_field = 1, n_fields + call op%field_desc(j_field)%clone(op%grid_desc%descs(i_field,j_field), info) + end do + end do + + ! 4) composed global descriptor + operator setup + call psb_cd_nest_compose(op%grid_desc, op%desc_glob, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='cd_nest_compose'); return + end if + call psb_z_nest_base_setup(nest_operator, op%block_storage, op%grid_desc, op%desc_glob, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='nest_base_setup'); return + end if + + ! 5) wrap into the standard matrix object (the pointers keep pointing at op%*) + allocate(op%a_glob%a, source=nest_operator, stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_; call psb_errpush(info, name); return + end if + call op%a_glob%set_nrows(op%desc_glob%get_local_rows()) + call op%a_glob%set_ncols(op%desc_glob%get_local_cols()) + call op%a_glob%set_asb() + + ! 6) the triplet buffers are no longer needed + do j_field = 1, n_fields + do i_field = 1, n_fields + call block_buffer_free(op%block_buffer(i_field,j_field)) + end do + end do + op%assembled = .true. + end subroutine psb_z_nest_op_asb + + ! free: release everything + subroutine psb_z_nest_op_free(op, info) + class(psb_z_nest_matrix), intent(inout) :: op + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i_field, j_field, local_info + + info = psb_success_ + if (allocated(op%block_buffer)) then + do j_field = 1, size(op%block_buffer,2) + do i_field = 1, size(op%block_buffer,1) + call block_buffer_free(op%block_buffer(i_field,j_field)) + end do + end do + deallocate(op%block_buffer, stat=local_info) + end if + if (op%assembled) then + call op%a_glob%free() + call op%desc_glob%free(local_info) + call op%grid_desc%free(local_info) + end if + if (allocated(op%field_desc)) then + do i_field = 1, size(op%field_desc) + call op%field_desc(i_field)%free(local_info) + end do + deallocate(op%field_desc, stat=local_info) + end if + op%n_fields = 0 + op%assembled = .false. + end subroutine psb_z_nest_op_free + + ! get_owned_rows: GLOBAL indices (in the field index space, 1..field size) + ! of the rows of field i_field owned by this process. This is the list of + ! rows the process is expected to insert through ins: + ! + ! my_rows = nested_matrix%get_owned_rows(1) + ! do k = 1, size(my_rows) + ! global_row = my_rows(k) + ! ... + ! + ! An empty array is returned for an out-of-range field index. + function psb_z_nest_op_get_owned_rows(op, i_field) result(owned_global_rows) + class(psb_z_nest_matrix), intent(in) :: op + integer(psb_ipk_), intent(in) :: i_field + integer(psb_lpk_), allocatable :: owned_global_rows(:) + + if ((i_field < 1) .or. (i_field > op%n_fields) .or. & + & (.not. allocated(op%field_desc))) then + allocate(owned_global_rows(0)) + return + end if + owned_global_rows = op%field_desc(i_field)%get_global_indices(owned=.true.) + end function psb_z_nest_op_get_owned_rows + + ! get_owned_row_count: how many rows of field i_field this process owns + function psb_z_nest_op_get_owned_row_count(op, i_field) result(owned_row_count) + class(psb_z_nest_matrix), intent(in) :: op + integer(psb_ipk_), intent(in) :: i_field + integer(psb_ipk_) :: owned_row_count + + owned_row_count = 0 + if ((i_field < 1) .or. (i_field > op%n_fields) .or. & + & (.not. allocated(op%field_desc))) return + owned_row_count = op%field_desc(i_field)%get_local_rows() + end function psb_z_nest_op_get_owned_row_count + + !----------------------------------------------------------------- + ! private helpers: growing triplet buffer + !----------------------------------------------------------------- + subroutine block_buffer_append(buffer, n_entries, entry_rows, entry_cols, entry_vals, info) + type(psb_z_nest_block_buffer), intent(inout) :: buffer + integer(psb_ipk_), intent(in) :: n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + complex(psb_dpk_), intent(in) :: entry_vals(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: required_size + + info = psb_success_ + required_size = buffer%n_entries + n_entries + call ensure_capacity_lpk(buffer%entry_rows, required_size, info); if (info /= 0) return + call ensure_capacity_lpk(buffer%entry_cols, required_size, info); if (info /= 0) return + call ensure_capacity_val(buffer%entry_vals, required_size, info); if (info /= 0) return + buffer%entry_rows(buffer%n_entries+1:required_size) = entry_rows(1:n_entries) + buffer%entry_cols(buffer%n_entries+1:required_size) = entry_cols(1:n_entries) + buffer%entry_vals(buffer%n_entries+1:required_size) = entry_vals(1:n_entries) + buffer%n_entries = required_size + end subroutine block_buffer_append + + subroutine ensure_capacity_lpk(array, required_size, info) + integer(psb_lpk_), allocatable, intent(inout) :: array(:) + integer(psb_ipk_), intent(in) :: required_size + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable :: grown(:) + integer(psb_ipk_) :: capacity + + info = 0 + if (.not. allocated(array)) then + allocate(array(max(required_size,16)), stat=info); return + end if + capacity = size(array) + if (required_size <= capacity) return + allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return + grown(1:capacity) = array(1:capacity) + call move_alloc(grown, array) + end subroutine ensure_capacity_lpk + + subroutine ensure_capacity_val(array, required_size, info) + complex(psb_dpk_), allocatable, intent(inout) :: array(:) + integer(psb_ipk_), intent(in) :: required_size + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), allocatable :: grown(:) + integer(psb_ipk_) :: capacity + + info = 0 + if (.not. allocated(array)) then + allocate(array(max(required_size,16)), stat=info); return + end if + capacity = size(array) + if (required_size <= capacity) return + allocate(grown(max(2*capacity, required_size)), stat=info); if (info /= 0) return + grown(1:capacity) = array(1:capacity) + call move_alloc(grown, array) + end subroutine ensure_capacity_val + + subroutine block_buffer_free(buffer) + type(psb_z_nest_block_buffer), intent(inout) :: buffer + if (allocated(buffer%entry_rows)) deallocate(buffer%entry_rows) + if (allocated(buffer%entry_cols)) deallocate(buffer%entry_cols) + if (allocated(buffer%entry_vals)) deallocate(buffer%entry_vals) + buffer%n_entries = 0 + end subroutine block_buffer_free + +end module psb_z_nest_builder_mod diff --git a/base/modules/tools/psb_z_nest_tools_mod.F90 b/base/modules/tools/psb_z_nest_tools_mod.F90 new file mode 100644 index 000000000..864c52548 --- /dev/null +++ b/base/modules/tools/psb_z_nest_tools_mod.F90 @@ -0,0 +1,364 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Module: psb_z_nest_tools_mod +! Author: Simone Staccone (Stack-1) +! +! Nested-specific assembly wrappers for PSBLAS3 — double precision matrix and vector routines +! + +module psb_z_nest_tools_mod + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_dpk_, psb_success_, psb_err_alloc_dealloc_, & + psb_err_invalid_input_, psb_err_from_subroutine_, & + psb_dupl_add_, psb_dupl_ovwrt_, psb_dupl_err_, psb_ctxt_type + use psb_error_mod, only : psb_errpush + use psb_z_tools_mod, only : psb_spall, psb_spins, psb_spasb, psb_spfree, psb_sprn, & + psb_geall, psb_geins, psb_geasb, psb_gefree + use psb_desc_nest_mod, only : psb_desc_nest_type + use psb_z_nest_mat_mod, only : psb_z_nest_sparse_mat + use psb_z_mat_mod, only : psb_zspmat_type + use psb_z_base_mat_mod, only : psb_z_coo_sparse_mat, psb_z_base_sparse_mat + use psb_desc_mod, only : psb_desc_type + implicit none + + private + + public :: psb_spall_nest, psb_spins_nest, psb_spasb_nest, psb_spfree_nest, psb_sprn_nest, & + psb_z_nest_rect_block + +contains + + ! Allocates all (nrblocks x ncblocks) sparse matrix blocks + ! and marks all as present. psb_spins_nest lazy-allocates individual + ! blocks on first insertion; call psb_spall_nest instead when the + ! full block structure is known up front. + + subroutine psb_spall_nest(a_nest, desc_nest, info, nnz) + type(psb_z_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: nnz + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spall_nest' + + a_nest%nrblocks = desc_nest%nrblocks + a_nest%ncblocks = desc_nest%ncblocks + + if (.not. allocated(a_nest%mats)) then + allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + return + end if + end if + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + local_info = psb_success_ + if (present(nnz)) then + call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, nnz=nnz) + else + call psb_spall(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + end if + if (local_info /= psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall') + return + end if + end do + end do + + end subroutine psb_spall_nest + + + ! Inserts nz entries into block (blk_i, blk_j) of the nested matrix. + ! The block is lazy-allocated on first insertion if psb_spall_nest + ! was not called first. + + subroutine psb_spins_nest(block_row, block_col, n_entries, entry_rows, entry_cols, entry_vals, a_nest, desc_nest, info) + integer(psb_ipk_), intent(in) :: block_row, block_col, n_entries + integer(psb_lpk_), intent(in) :: entry_rows(:), entry_cols(:) + complex(psb_dpk_), intent(in) :: entry_vals(:) + type(psb_z_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(inout) :: desc_nest + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nnz_estimate + character(len=20) :: name + + info = psb_success_ + name = 'psb_spins_nest' + + if (n_entries == 0) return + + if (block_row < 1 .or. block_row > a_nest%nrblocks .or. & + block_col < 1 .or. block_col > a_nest%ncblocks) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='invalid block indices') + return + end if + + if (.not. allocated(a_nest%mats)) then + allocate(a_nest%mats(a_nest%nrblocks, a_nest%ncblocks), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + return + end if + end if + + if (.not. allocated(a_nest%mats(block_row, block_col)%a)) then + ! Estimate nnz: use n_entries + 50% buffer for future insertions + nnz_estimate = max(n_entries, 10) + n_entries / 2 + call psb_spall(a_nest%mats(block_row, block_col), & + desc_nest%descs(block_row, block_col), info, nnz=nnz_estimate) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spall') + return + end if + end if + + call psb_spins(n_entries, entry_rows, entry_cols, entry_vals, a_nest%mats(block_row, block_col), & + desc_nest%descs(block_row, block_col), info) + if (info /= psb_success_) & + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spins') + + end subroutine psb_spins_nest + + ! Calls psb_spasb on all present block matrices. + ! Must be called after psb_cdasb_nest. + + subroutine psb_spasb_nest(a_nest, desc_nest, info, dupl) + type(psb_z_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(inout) :: desc_nest + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dupl + + integer(psb_ipk_) :: i_block_row, j_block_col, dupl_mode, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spasb_nest' + dupl_mode = psb_dupl_add_ + if (present(dupl)) dupl_mode = dupl + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + if (dupl_mode == psb_dupl_add_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_add_) + else if (dupl_mode == psb_dupl_ovwrt_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_ovwrt_) + else if (dupl_mode == psb_dupl_err_) then + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info, dupl=psb_dupl_err_) + else + call psb_spasb(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), & + local_info) + end if + if (local_info /= psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spasb') + return + end if + end if + end do + end do + + end subroutine psb_spasb_nest + + ! Calls psb_spfree on every present block, then deallocates the + ! mats array and resets nrblocks/ncblocks to 0. + + subroutine psb_spfree_nest(a_nest, desc_nest, info) + type(psb_z_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_spfree_nest' + + if (allocated(a_nest%mats)) then + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + call psb_spfree(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + if (local_info /= psb_success_ .and. info == psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_spfree') + end if + end if + end do + end do + deallocate(a_nest%mats, stat=local_info) + if (local_info /= 0 .and. info == psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + end if + end if + + a_nest%nrblocks = 0 + a_nest%ncblocks = 0 + + end subroutine psb_spfree_nest + + ! Calls psb_sprn on every present block matrix, resetting it to + ! the build state while preserving the sparsity pattern. + + subroutine psb_sprn_nest(a_nest, desc_nest, info, clear) + type(psb_z_nest_sparse_mat), intent(inout) :: a_nest + type(psb_desc_nest_type), intent(in) :: desc_nest + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: i_block_row, j_block_col, local_info + character(len=20) :: name + + info = psb_success_ + name = 'psb_sprn_nest' + + if (.not. allocated(a_nest%mats)) return + + do i_block_row = 1, a_nest%nrblocks + do j_block_col = 1, a_nest%ncblocks + if (allocated(a_nest%mats(i_block_row, j_block_col)%a)) then + local_info = psb_success_ + if (present(clear)) then + call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info, clear=clear) + else + call psb_sprn(a_nest%mats(i_block_row, j_block_col), desc_nest%descs(i_block_row, j_block_col), local_info) + end if + if (local_info /= psb_success_ .and. info == psb_success_) then + info = local_info + call psb_errpush(psb_err_from_subroutine_, name, a_err='psb_sprn') + end if + end if + end do + end do + + end subroutine psb_sprn_nest + + + + ! psb_z_nest_rect_block + ! + ! Build a local GENERAL (possibly rectangular) block A(i,j) of a nested + ! operator, with rows in field i and columns in field j (field i /= field j, + ! |field i| /= |field j| allowed). Rows are localized against the field-i + ! (row) descriptor, columns against the field-j (column) descriptor — which + ! must already carry the union halo of column j (cdall + cdins(all column-j + ! blocks' columns) + cdasb). The result is a CSR block of shape + ! (field-i owned rows) x (field-j local cols incl. halo) + ! consumable directly by the nested csmv (psb_z_nest_base_mat). + ! + ! A single-descriptor psb_spall/psb_spasb cannot express row-field /= col-field + ! (it would force rows and columns into the same index space), hence the + ! explicit COO build with separate row/column localization. + ! + ! Arguments (this process's local contribution): + ! blk (out) the assembled block (CSR) + ! nz number of local entries + ! ia_glob(:) GLOBAL field-i row indices (owned by this process) + ! ja_glob(:) GLOBAL field-j column indices + ! val(:) values + ! desc_row field-i descriptor (rows) + ! desc_col field-j descriptor (columns, with union halo) + ! + subroutine psb_z_nest_rect_block(blk, nz, ia_glob, ja_glob, val, desc_row, desc_col, info, type, mold) + type(psb_zspmat_type), intent(out) :: blk + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia_glob(:), ja_glob(:) + complex(psb_dpk_), intent(in) :: val(:) + type(psb_desc_type), intent(in) :: desc_row, desc_col + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: type ! base storage format (default 'CSR') + class(psb_z_base_sparse_mat), intent(in), optional :: mold ! any format, e.g. psb_ext ELL/HLL + + type(psb_z_coo_sparse_mat) :: coo_block + integer(psb_ipk_) :: k_entry, n_loc_rows, n_loc_cols, loc_row, loc_col + character(len=24) :: name + + info = psb_success_ + name = 'psb_z_nest_rect_block' + + n_loc_rows = desc_row%get_local_rows() ! owned rows of field i + n_loc_cols = desc_col%get_local_cols() ! field-j local cols (owned + halo) + + call coo_block%allocate(n_loc_rows, n_loc_cols, nz) + do k_entry = 1, nz + call desc_row%g2l(ia_glob(k_entry), loc_row, info) + if (info /= 0 .or. loc_row < 1 .or. loc_row > n_loc_rows) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='row not owned / not localizable') + return + end if + call desc_col%g2l(ja_glob(k_entry), loc_col, info) + if (info /= 0 .or. loc_col < 1 .or. loc_col > n_loc_cols) then + info = psb_err_invalid_input_ + call psb_errpush(info, name, a_err='column not in field-j descriptor (missing from union halo)') + return + end if + coo_block%ia(k_entry) = loc_row + coo_block%ja(k_entry) = loc_col + coo_block%val(k_entry) = val(k_entry) + end do + call coo_block%set_nzeros(nz) + call coo_block%set_dupl(psb_dupl_add_) + call coo_block%fix(info) + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='coo fix'); return + end if + call blk%mv_from(coo_block) + if (present(mold)) then + call blk%cscnv(info, mold=mold) + else if (present(type)) then + call blk%cscnv(info, type=type) + else + call blk%cscnv(info, type='CSR') + end if + if (info /= 0) then + call psb_errpush(psb_err_from_subroutine_, name, a_err='cscnv'); return + end if + end subroutine psb_z_nest_rect_block + +end module psb_z_nest_tools_mod