From d0cacda995a98e4b7d3e57ca404421d03d2cc192 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 29 Aug 2023 16:19:56 +0200 Subject: [PATCH] Moved various modules related to RB around, into auxil, update Makefile. --- README.md | 1 + base/modules/Makefile | 18 +- base/modules/auxil/psb_d_rb_idx_tree_mod.f90 | 128 +++++ base/modules/auxil/psb_rb_idx_tree_mod.f90 | 49 ++ base/modules/auxil/psb_sort_mod.f90 | 3 +- .../sort => modules/auxil}/psi_acx_mod.f90 | 0 .../sort => modules/auxil}/psi_alcx_mod.f90 | 0 .../sort => modules/auxil}/psi_lcx_mod.f90 | 0 base/modules/serial/psb_d_rb_idx_tree_mod.f90 | 91 ---- base/modules/serial/psb_rb_idx_tree_mod.f90 | 5 - base/serial/impl/psb_d_rb_idx_tree_impl.F90 | 504 ++++++++++-------- base/serial/sort/Makefile | 4 +- 12 files changed, 467 insertions(+), 336 deletions(-) create mode 100644 base/modules/auxil/psb_d_rb_idx_tree_mod.f90 create mode 100644 base/modules/auxil/psb_rb_idx_tree_mod.f90 rename base/{serial/sort => modules/auxil}/psi_acx_mod.f90 (100%) rename base/{serial/sort => modules/auxil}/psi_alcx_mod.f90 (100%) rename base/{serial/sort => modules/auxil}/psi_lcx_mod.f90 (100%) delete mode 100644 base/modules/serial/psb_d_rb_idx_tree_mod.f90 delete mode 100644 base/modules/serial/psb_rb_idx_tree_mod.f90 diff --git a/README.md b/README.md index 86bb2805..a9813f5e 100644 --- a/README.md +++ b/README.md @@ -121,6 +121,7 @@ Salvatore Filippone Contributors (roughly reverse cronological order): +Dimitri Walther Andea Di Iorio Stefano Petrilli Soren Rasmussen diff --git a/base/modules/Makefile b/base/modules/Makefile index 0d90b9f1..8fa63f92 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -60,12 +60,12 @@ SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ auxil/psb_d_hsort_x_mod.o \ auxil/psb_c_hsort_x_mod.o \ auxil/psb_z_hsort_x_mod.o \ + auxil/psb_d_rb_idx_tree_mod.o auxil/psb_rb_idx_tree_mod.o \ serial/psb_base_mat_mod.o serial/psb_mat_mod.o\ serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_mat_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_rb_idx_tree_mod.o serial/psb_rb_idx_tree_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_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 #\ @@ -166,6 +166,7 @@ penv/psi_d_collective_mod.o penv/psi_c_collective_mod.o penv/psi_z_collective_m penv/psi_d_p2p_mod.o penv/psi_c_p2p_mod.o penv/psi_z_p2p_mod.o +auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o \ auxil/psb_string_mod.o auxil/psb_m_realloc_mod.o auxil/psb_e_realloc_mod.o auxil/psb_s_realloc_mod.o \ auxil/psb_d_realloc_mod.o auxil/psb_c_realloc_mod.o auxil/psb_z_realloc_mod.o \ desc/psb_desc_const_mod.o psi_penv_mod.o: psb_const_mod.o @@ -175,6 +176,7 @@ desc/psb_indx_map_mod.o desc/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o auxil/psb_i_sort_mod.o auxil/psb_s_sort_mod.o auxil/psb_d_sort_mod.o auxil/psb_c_sort_mod.o auxil/psb_z_sort_mod.o \ auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o auxil/psb_sort_mod.o: $(BASIC_MODS) + auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ @@ -193,7 +195,8 @@ auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_d_hsort_x_mod.o \ auxil/psb_c_hsort_x_mod.o \ auxil/psb_z_hsort_x_mod.o \ - auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o + auxil/psb_ip_reord_mod.o \ + auxil/psi_serial_mod.o auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ @@ -226,7 +229,10 @@ auxil/psb_c_hsort_x_mod.o: auxil/psb_c_hsort_mod.o auxil/psb_z_hsort_x_mod.o: auxil/psb_z_hsort_mod.o auxil/psi_serial_mod.o: auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ - auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o + auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o\ + auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o \ + auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o + auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o: psb_const_mod.o auxil/psb_ip_reord_mod.o: auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ @@ -271,8 +277,8 @@ serial/psb_z_vect_mod.o: serial/psb_z_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o: serial/psb_mat_mod.o auxil/psb_string_mod.o auxil/psb_sort_mod.o auxil/psi_serial_mod.o serial/psb_vect_mod.o: serial/psb_i_vect_mod.o serial/psb_l_vect_mod.o serial/psb_d_vect_mod.o serial/psb_s_vect_mod.o serial/psb_c_vect_mod.o serial/psb_z_vect_mod.o -serial/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o psb_realloc_mod.o -serial/psb_rb_idx_tree_mod.o: serial/psb_d_rb_idx_tree_mod.o +auxil/psb_d_rb_idx_tree_mod.o: serial/psb_d_csr_mat_mod.o psb_realloc_mod.o +auxil/psb_rb_idx_tree_mod.o: auxil/psb_d_rb_idx_tree_mod.o error.o psb_realloc_mod.o: psb_error_mod.o psb_error_impl.o: psb_penv_mod.o diff --git a/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 new file mode 100644 index 00000000..099d1a30 --- /dev/null +++ b/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 @@ -0,0 +1,128 @@ +! +! 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. +! +! +! +! package: psb_d_rb_idx_tree_mod +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +module psb_d_rb_idx_tree_mod + use psb_const_mod + implicit none + + type :: psb_d_rb_idx_node + integer(psb_ipk_) :: idx + real(psb_dpk_) :: val + type(psb_d_rb_idx_node), pointer :: left, right, parent + logical :: is_red + end type psb_d_rb_idx_node + + type :: psb_d_rb_idx_tree + type(psb_d_rb_idx_node), pointer :: root + integer(psb_ipk_) :: nnz + + contains + + procedure :: insert => psb_d_rb_idx_tree_insert + end type psb_d_rb_idx_tree + + interface psb_rb_idx_tree_insert + subroutine psb_d_rb_idx_tree_insert(this, idx, val) + import :: psb_ipk_, psb_dpk_, psb_d_rb_idx_tree + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + real(psb_dpk_), intent(in) :: val + end subroutine psb_d_rb_idx_tree_insert + end interface psb_rb_idx_tree_insert + + interface psb_rb_idx_tree_scalar_sparse_row_mul + subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + import :: psb_ipk_, psb_dpk_, psb_d_rb_idx_tree + implicit none + type(psb_d_rb_idx_tree), intent(inout) :: tree + real(psb_dpk_), intent(in) :: scalar + type(psb_d_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + end subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul + end interface psb_rb_idx_tree_scalar_sparse_row_mul + + interface psb_rb_idx_tree_merge + subroutine psb_d_rb_idx_tree_merge(trees, mat) + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + import :: psb_d_rb_idx_tree + type(psb_d_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_d_csr_sparse_mat), intent(inout) :: mat + end subroutine psb_d_rb_idx_tree_merge + end interface psb_rb_idx_tree_merge + + interface psb_rb_idx_tree_fix_insertion + subroutine psb_d_rb_idx_tree_fix_insertion(this, node) + import :: psb_d_rb_idx_tree, psb_d_rb_idx_node + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_d_rb_idx_tree_fix_insertion + end interface psb_rb_idx_tree_fix_insertion + + interface psb_rb_idx_tree_swap_colors + subroutine psb_d_rb_idx_tree_swap_colors(n1, n2) + import :: psb_d_rb_idx_node + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: n1, n2 + end subroutine psb_d_rb_idx_tree_swap_colors + end interface psb_rb_idx_tree_swap_colors + + interface psb_rb_idx_tree_rotate_right + subroutine psb_d_rb_idx_tree_rotate_right(node) + import :: psb_d_rb_idx_node + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_d_rb_idx_tree_rotate_right + end interface psb_rb_idx_tree_rotate_right + + interface psb_rb_idx_tree_rotate_left + subroutine psb_d_rb_idx_tree_rotate_left(node) + import :: psb_d_rb_idx_node + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + end subroutine psb_d_rb_idx_tree_rotate_left + end interface psb_rb_idx_tree_rotate_left +end module psb_d_rb_idx_tree_mod diff --git a/base/modules/auxil/psb_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_rb_idx_tree_mod.f90 new file mode 100644 index 00000000..9d151389 --- /dev/null +++ b/base/modules/auxil/psb_rb_idx_tree_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. +! +! +! +! package: psb_rb_idx_tree_mod +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! +module psb_rb_idx_tree_mod + use psb_const_mod + + use psb_d_rb_idx_tree_mod +end module psb_rb_idx_tree_mod diff --git a/base/modules/auxil/psb_sort_mod.f90 b/base/modules/auxil/psb_sort_mod.f90 index 0bd7bdfc..e980dc2b 100644 --- a/base/modules/auxil/psb_sort_mod.f90 +++ b/base/modules/auxil/psb_sort_mod.f90 @@ -45,7 +45,8 @@ module psb_sort_mod use psb_const_mod use psb_ip_reord_mod - + use psi_serial_mod + use psb_m_hsort_mod use psb_m_isort_mod use psb_m_msort_mod diff --git a/base/serial/sort/psi_acx_mod.f90 b/base/modules/auxil/psi_acx_mod.f90 similarity index 100% rename from base/serial/sort/psi_acx_mod.f90 rename to base/modules/auxil/psi_acx_mod.f90 diff --git a/base/serial/sort/psi_alcx_mod.f90 b/base/modules/auxil/psi_alcx_mod.f90 similarity index 100% rename from base/serial/sort/psi_alcx_mod.f90 rename to base/modules/auxil/psi_alcx_mod.f90 diff --git a/base/serial/sort/psi_lcx_mod.f90 b/base/modules/auxil/psi_lcx_mod.f90 similarity index 100% rename from base/serial/sort/psi_lcx_mod.f90 rename to base/modules/auxil/psi_lcx_mod.f90 diff --git a/base/modules/serial/psb_d_rb_idx_tree_mod.f90 b/base/modules/serial/psb_d_rb_idx_tree_mod.f90 deleted file mode 100644 index afdd831d..00000000 --- a/base/modules/serial/psb_d_rb_idx_tree_mod.f90 +++ /dev/null @@ -1,91 +0,0 @@ -! Red black tree implementation ordered by index -! -! Each node contains and index and a double precision value -! -! The tree should always be well balanced -! -! inserting a node with an existing index will -! add up the new value to the old one -module psb_d_rb_idx_tree_mod - use psb_const_mod - implicit none - type :: psb_d_rb_idx_node - integer(psb_ipk_) :: idx - real(psb_dpk_) :: val - type(psb_d_rb_idx_node), pointer :: left, right, parent - logical :: is_red - end type psb_d_rb_idx_node - - type :: psb_d_rb_idx_tree - type(psb_d_rb_idx_node), pointer :: root - integer(psb_ipk_) :: nnz - - contains - - procedure :: insert => psb_d_rb_idx_tree_insert - end type psb_d_rb_idx_tree - - interface psb_rb_idx_tree_insert - subroutine psb_d_rb_idx_tree_insert(this, idx, val) - import :: psb_ipk_, psb_dpk_, psb_d_rb_idx_tree - implicit none - class(psb_d_rb_idx_tree), intent(inout) :: this - integer(psb_ipk_), intent(in) :: idx - real(psb_dpk_), intent(in) :: val - end subroutine psb_d_rb_idx_tree_insert - end interface psb_rb_idx_tree_insert - - interface psb_rb_idx_tree_scalar_sparse_row_mul - subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat - import :: psb_ipk_, psb_dpk_, psb_d_rb_idx_tree - implicit none - type(psb_d_rb_idx_tree), intent(inout) :: tree - real(psb_dpk_), intent(in) :: scalar - type(psb_d_csr_sparse_mat), intent(in) :: mat - integer(psb_ipk_), intent(in) :: row_num - end subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul - end interface psb_rb_idx_tree_scalar_sparse_row_mul - - interface psb_rb_idx_tree_merge - subroutine psb_d_rb_idx_tree_merge(trees, mat) - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat - import :: psb_d_rb_idx_tree - type(psb_d_rb_idx_tree), allocatable, intent(inout) :: trees(:) - type(psb_d_csr_sparse_mat), intent(inout) :: mat - end subroutine psb_d_rb_idx_tree_merge - end interface psb_rb_idx_tree_merge - - interface psb_rb_idx_tree_fix_insertion - subroutine psb_d_rb_idx_tree_fix_insertion(this, node) - import :: psb_d_rb_idx_tree, psb_d_rb_idx_node - implicit none - class(psb_d_rb_idx_tree), intent(inout) :: this - type(psb_d_rb_idx_node), pointer, intent(inout) :: node - end subroutine psb_d_rb_idx_tree_fix_insertion - end interface psb_rb_idx_tree_fix_insertion - - interface psb_rb_idx_tree_swap_colors - subroutine psb_d_rb_idx_tree_swap_colors(n1, n2) - import :: psb_d_rb_idx_node - implicit none - type(psb_d_rb_idx_node), pointer, intent(inout) :: n1, n2 - end subroutine psb_d_rb_idx_tree_swap_colors - end interface psb_rb_idx_tree_swap_colors - - interface psb_rb_idx_tree_rotate_right - subroutine psb_d_rb_idx_tree_rotate_right(node) - import :: psb_d_rb_idx_node - implicit none - type(psb_d_rb_idx_node), pointer, intent(inout) :: node - end subroutine psb_d_rb_idx_tree_rotate_right - end interface psb_rb_idx_tree_rotate_right - - interface psb_rb_idx_tree_rotate_left - subroutine psb_d_rb_idx_tree_rotate_left(node) - import :: psb_d_rb_idx_node - implicit none - type(psb_d_rb_idx_node), pointer, intent(inout) :: node - end subroutine psb_d_rb_idx_tree_rotate_left - end interface psb_rb_idx_tree_rotate_left -end module psb_d_rb_idx_tree_mod \ No newline at end of file diff --git a/base/modules/serial/psb_rb_idx_tree_mod.f90 b/base/modules/serial/psb_rb_idx_tree_mod.f90 deleted file mode 100644 index e93554f1..00000000 --- a/base/modules/serial/psb_rb_idx_tree_mod.f90 +++ /dev/null @@ -1,5 +0,0 @@ -module psb_rb_idx_tree_mod - use psb_const_mod - - use psb_d_rb_idx_tree_mod -end module psb_rb_idx_tree_mod \ No newline at end of file diff --git a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 index a6bdc86f..9b63d51c 100644 --- a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 +++ b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 @@ -1,285 +1,329 @@ +! +! 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. +! +! +! +! package: psb_d_rb_idx_tree_impl +! +! Red black tree implementation ordered by index +! +! Each node contains and index and a double precision value +! +! The tree should always be well balanced +! +! inserting a node with an existing index will +! add up the new value to the old one +! Contributed by Dimitri Walther +! subroutine psb_d_rb_idx_tree_insert(this, idx, val) - use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_insert - implicit none - class(psb_d_rb_idx_tree), intent(inout) :: this - integer(psb_ipk_), intent(in) :: idx - real(psb_dpk_), intent(in) :: val - - character(len=22) :: name - type(psb_d_rb_idx_node), pointer :: new_node - type(psb_d_rb_idx_node), pointer :: current, previous - name='psb_rb_idx_tree_insert' - - allocate(new_node) - new_node%idx = idx - new_node%val = val - nullify(new_node%left) - nullify(new_node%right) - nullify(new_node%parent) - new_node%is_red = .true. - - - if (.not. associated(this%root)) then - this%root => new_node - this%nnz = 1 - new_node%is_red = .false. - return - end if + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_insert + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + integer(psb_ipk_), intent(in) :: idx + real(psb_dpk_), intent(in) :: val + + character(len=22) :: name + type(psb_d_rb_idx_node), pointer :: new_node + type(psb_d_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_insert' + + allocate(new_node) + new_node%idx = idx + new_node%val = val + nullify(new_node%left) + nullify(new_node%right) + nullify(new_node%parent) + new_node%is_red = .true. + + + if (.not. associated(this%root)) then + this%root => new_node + this%nnz = 1 + new_node%is_red = .false. + return + end if + + current => this%root + + do while (associated(current)) + previous => current + + if (idx == current%idx) then + current%val = current%val + val + deallocate(new_node) + return + else if (idx < current%idx) then + current => current%left + else - current => this%root + current => current%right + end if + end do - do while (associated(current)) - previous => current + if (idx < previous%idx) then + new_node%parent => previous + previous%left => new_node + else + new_node%parent => previous + previous%right => new_node + end if - if (idx == current%idx) then - current%val = current%val + val - deallocate(new_node) - return - else if (idx < current%idx) then - current => current%left - else + call psb_d_rb_idx_tree_fix_insertion(this, new_node) - current => current%right - end if - end do + this%nnz = this%nnz + 1 +end subroutine psb_d_rb_idx_tree_insert - if (idx < previous%idx) then - new_node%parent => previous - previous%left => new_node +subroutine psb_d_rb_idx_tree_fix_insertion(this, node) + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_fix_insertion + implicit none + class(psb_d_rb_idx_tree), intent(inout) :: this + type(psb_d_rb_idx_node), pointer, intent(inout) :: node + + character(len=29) :: name + type(psb_d_rb_idx_node), pointer :: current, parent, grand_parent, uncle + name = 'psb_rb_idx_tree_fix_insertion' + + current => node + parent => current%parent + do while(associated(parent) .and. parent%is_red) + ! grand parent exist because root can't be red + grand_parent => parent%parent + if (parent%idx < grand_parent%idx) then + uncle => grand_parent%right else - new_node%parent => previous - previous%right => new_node + uncle => grand_parent%left end if - call psb_d_rb_idx_tree_fix_insertion(this, new_node) - - this%nnz = this%nnz + 1 -end subroutine psb_d_rb_idx_tree_insert + if (associated(uncle) .and. uncle%is_red) then + parent%is_red = .false. + uncle%is_red = .false. + grand_parent%is_red = .true. + current => grand_parent + parent => current%parent + + ! Left-Left case + else if (current%idx < parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_d_rb_idx_tree_rotate_right(grand_parent) + call psb_d_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Left-Right case + else if (current%idx > parent%idx .and. & + parent%idx < grand_parent%idx) then + call psb_d_rb_idx_tree_rotate_left(parent) + call psb_d_rb_idx_tree_rotate_right(grand_parent) + call psb_d_rb_idx_tree_swap_colors(current, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => current + + return + ! Right-Right case + else if (current%idx > parent%idx .and. & + parent%idx > grand_parent%idx) then + call psb_d_rb_idx_tree_rotate_left(grand_parent) + call psb_d_rb_idx_tree_swap_colors(parent, grand_parent) + + if (this%root%idx == grand_parent%idx) this%root => parent + + return + ! Right-Left case + else + call psb_d_rb_idx_tree_rotate_right(parent) + call psb_d_rb_idx_tree_rotate_left(grand_parent) + call psb_d_rb_idx_tree_swap_colors(current, grand_parent) -subroutine psb_d_rb_idx_tree_fix_insertion(this, node) - use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_fix_insertion - implicit none - class(psb_d_rb_idx_tree), intent(inout) :: this - type(psb_d_rb_idx_node), pointer, intent(inout) :: node - - character(len=29) :: name - type(psb_d_rb_idx_node), pointer :: current, parent, grand_parent, uncle - name = 'psb_rb_idx_tree_fix_insertion' - - current => node - parent => current%parent - do while(associated(parent) .and. parent%is_red) - ! grand parent exist because root can't be red - grand_parent => parent%parent - if (parent%idx < grand_parent%idx) then - uncle => grand_parent%right - else - uncle => grand_parent%left - end if + if (this%root%idx == grand_parent%idx) this%root => current - if (associated(uncle) .and. uncle%is_red) then - parent%is_red = .false. - uncle%is_red = .false. - grand_parent%is_red = .true. - current => grand_parent - parent => current%parent - - ! Left-Left case - else if (current%idx < parent%idx .and. & - parent%idx < grand_parent%idx) then - call psb_d_rb_idx_tree_rotate_right(grand_parent) - call psb_d_rb_idx_tree_swap_colors(parent, grand_parent) - - if (this%root%idx == grand_parent%idx) this%root => parent - - return - ! Left-Right case - else if (current%idx > parent%idx .and. & - parent%idx < grand_parent%idx) then - call psb_d_rb_idx_tree_rotate_left(parent) - call psb_d_rb_idx_tree_rotate_right(grand_parent) - call psb_d_rb_idx_tree_swap_colors(current, grand_parent) - - if (this%root%idx == grand_parent%idx) this%root => current - - return - ! Right-Right case - else if (current%idx > parent%idx .and. & - parent%idx > grand_parent%idx) then - call psb_d_rb_idx_tree_rotate_left(grand_parent) - call psb_d_rb_idx_tree_swap_colors(parent, grand_parent) - - if (this%root%idx == grand_parent%idx) this%root => parent - - return - ! Right-Left case - else - call psb_d_rb_idx_tree_rotate_right(parent) - call psb_d_rb_idx_tree_rotate_left(grand_parent) - call psb_d_rb_idx_tree_swap_colors(current, grand_parent) - - if (this%root%idx == grand_parent%idx) this%root => current - - return - end if - end do + return + end if + end do - this%root%is_red = .false. + this%root%is_red = .false. end subroutine psb_d_rb_idx_tree_fix_insertion subroutine psb_d_rb_idx_tree_swap_colors(n1, n2) - use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_swap_colors - implicit none - type(psb_d_rb_idx_node), pointer, intent(inout) :: n1, n2 + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_swap_colors + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: n1, n2 - character(len=27) :: name - logical :: tmp - name='psb_rb_idx_tree_swap_colors' + character(len=27) :: name + logical :: tmp + name='psb_rb_idx_tree_swap_colors' - tmp = n1%is_red - n1%is_red = n2%is_red - n2%is_red = tmp + tmp = n1%is_red + n1%is_red = n2%is_red + n2%is_red = tmp end subroutine psb_d_rb_idx_tree_swap_colors subroutine psb_d_rb_idx_tree_rotate_right(node) - use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_rotate_right - implicit none - type(psb_d_rb_idx_node), pointer, intent(inout) :: node + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_rotate_right + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node - character(len=28) :: name - type(psb_d_rb_idx_node), pointer :: l, lr - name='psb_rb_idx_tree_rotate_right' + character(len=28) :: name + type(psb_d_rb_idx_node), pointer :: l, lr + name='psb_rb_idx_tree_rotate_right' - if (.not. associated(node%left)) return + if (.not. associated(node%left)) return - l => node%left - lr => l%right - node%left => lr + l => node%left + lr => l%right + node%left => lr - if (associated(lr)) lr%parent => node + if (associated(lr)) lr%parent => node - if (associated(node%parent)) then - if (node%idx < node%parent%idx) then - node%parent%left => l - else - node%parent%right => l - end if + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => l + else + node%parent%right => l end if + end if - l%parent => node%parent - node%parent => l + l%parent => node%parent + node%parent => l - l%right => node + l%right => node end subroutine psb_d_rb_idx_tree_rotate_right subroutine psb_d_rb_idx_tree_rotate_left(node) - use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_rotate_left - implicit none - type(psb_d_rb_idx_node), pointer, intent(inout) :: node + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_rotate_left + implicit none + type(psb_d_rb_idx_node), pointer, intent(inout) :: node - character(len=27) :: name - type(psb_d_rb_idx_node), pointer :: r, rl - name='psb_rb_idx_tree_rotate_left' + character(len=27) :: name + type(psb_d_rb_idx_node), pointer :: r, rl + name='psb_rb_idx_tree_rotate_left' - if (.not. associated(node%right)) return + if (.not. associated(node%right)) return - r => node%right - rl => r%left - node%right => rl + r => node%right + rl => r%left + node%right => rl - if (associated(rl)) rl%parent => node + if (associated(rl)) rl%parent => node - if (associated(node%parent)) then - if (node%idx < node%parent%idx) then - node%parent%left => r - else - node%parent%right => r - end if + if (associated(node%parent)) then + if (node%idx < node%parent%idx) then + node%parent%left => r + else + node%parent%right => r end if + end if - r%parent => node%parent - node%parent => r + r%parent => node%parent + node%parent => r - r%left => node + r%left => node end subroutine psb_d_rb_idx_tree_rotate_left subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul(tree, scalar, mat, row_num) - use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_scalar_sparse_row_mul - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat - implicit none - type(psb_d_rb_idx_tree), intent(inout) :: tree - real(psb_dpk_), intent(in) :: scalar - type(psb_d_csr_sparse_mat), intent(in) :: mat - integer(psb_ipk_), intent(in) :: row_num - - character(len=37) :: name - integer(psb_ipk_) :: i - name='psb_rb_idx_tree_scalar_sparse_row_mul' - - do i = mat%irp(row_num), mat%irp(row_num + 1) - 1 - call tree%insert(mat%ja(i),scalar * mat%val(i)) - end do + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_scalar_sparse_row_mul + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + implicit none + type(psb_d_rb_idx_tree), intent(inout) :: tree + real(psb_dpk_), intent(in) :: scalar + type(psb_d_csr_sparse_mat), intent(in) :: mat + integer(psb_ipk_), intent(in) :: row_num + + character(len=37) :: name + integer(psb_ipk_) :: i + name='psb_rb_idx_tree_scalar_sparse_row_mul' + + do i = mat%irp(row_num), mat%irp(row_num + 1) - 1 + call tree%insert(mat%ja(i),scalar * mat%val(i)) + end do end subroutine psb_d_rb_idx_tree_scalar_sparse_row_mul subroutine psb_d_rb_idx_tree_merge(trees, mat) #if defined(OPENMP) - use omp_lib + use omp_lib #endif - use psb_realloc_mod - use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_merge - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat - implicit none - type(psb_d_rb_idx_tree), allocatable, intent(inout) :: trees(:) - type(psb_d_csr_sparse_mat), intent(inout) :: mat - - character(len=21) :: name - integer(psb_ipk_) :: i, j, rows, info, nnz - type(psb_d_rb_idx_node), pointer :: current, previous - name='psb_rb_idx_tree_merge' - - rows = size(trees) - - mat%irp(1) = 1 - - do i=1, rows - mat%irp(i + 1) = mat%irp(i) + trees(i)%nnz - end do + use psb_realloc_mod + use psb_d_rb_idx_tree_mod, psb_protect_name => psb_d_rb_idx_tree_merge + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat + implicit none + type(psb_d_rb_idx_tree), allocatable, intent(inout) :: trees(:) + type(psb_d_csr_sparse_mat), intent(inout) :: mat + + character(len=21) :: name + integer(psb_ipk_) :: i, j, rows, info, nnz + type(psb_d_rb_idx_node), pointer :: current, previous + name='psb_rb_idx_tree_merge' + + rows = size(trees) - nnz = mat%irp(rows + 1) - call psb_realloc(nnz, mat%val, info) - call psb_realloc(nnz, mat%ja, info) + mat%irp(1) = 1 + + do i=1, rows + mat%irp(i + 1) = mat%irp(i) + trees(i)%nnz + end do + + nnz = mat%irp(rows + 1) + call psb_realloc(nnz, mat%val, info) + call psb_realloc(nnz, mat%ja, info) #if defined(OPENMP) - !$omp parallel do schedule(static), private(current, previous, j) + !$omp parallel do schedule(static), private(current, previous, j) #endif - do i = 1, size(trees) - j = 0 - current => trees(i)%root - do while(associated(current)) - ! go to the left-most node - do while(associated(current%left)) - current => current%left - end do - mat%val(j + mat%irp(i)) = current%val - mat%ja(j + mat%irp(i)) = current%idx - j = j + 1 - - previous => current - if (associated(current%right)) then - if (associated(current%parent)) then - current%parent%left => current%right - end if - current%right%parent => current%parent - current => current%right - else - current => current%parent - if (associated(current)) nullify(current%left) - end if - deallocate(previous) - end do + do i = 1, size(trees) + j = 0 + current => trees(i)%root + do while(associated(current)) + ! go to the left-most node + do while(associated(current%left)) + current => current%left + end do + mat%val(j + mat%irp(i)) = current%val + mat%ja(j + mat%irp(i)) = current%idx + j = j + 1 + + previous => current + if (associated(current%right)) then + if (associated(current%parent)) then + current%parent%left => current%right + end if + current%right%parent => current%parent + current => current%right + else + current => current%parent + if (associated(current)) nullify(current%left) + end if + deallocate(previous) end do + end do #if defined(OPENMP) - !$omp end parallel do + !$omp end parallel do #endif -end subroutine psb_d_rb_idx_tree_merge \ No newline at end of file +end subroutine psb_d_rb_idx_tree_merge diff --git a/base/serial/sort/Makefile b/base/serial/sort/Makefile index 2ef6420a..ff8fd620 100644 --- a/base/serial/sort/Makefile +++ b/base/serial/sort/Makefile @@ -3,7 +3,6 @@ include ../../../Make.inc # # The object files # -BOBJS=psi_lcx_mod.o psi_alcx_mod.o psi_acx_mod.o IOBJS=psb_m_hsort_impl.o psb_m_isort_impl.o psb_m_msort_impl.o psb_m_qsort_impl.o LOBJS=psb_e_hsort_impl.o psb_e_isort_impl.o psb_e_msort_impl.o psb_e_qsort_impl.o SOBJS=psb_s_hsort_impl.o psb_s_isort_impl.o psb_s_msort_impl.o psb_s_qsort_impl.o @@ -11,7 +10,7 @@ DOBJS=psb_d_hsort_impl.o psb_d_isort_impl.o psb_d_msort_impl.o psb_d_qsort_impl. COBJS=psb_c_hsort_impl.o psb_c_isort_impl.o psb_c_msort_impl.o psb_c_qsort_impl.o ZOBJS=psb_z_hsort_impl.o psb_z_isort_impl.o psb_z_msort_impl.o psb_z_qsort_impl.o -OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) $(IOBJS) $(LOBJS) +OBJS=$(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) $(IOBJS) $(LOBJS) # # Where the library should go, and how it is called. @@ -35,7 +34,6 @@ lib: objs # A bit excessive, but safe $(OBJS): $(MODDIR)/psb_base_mod.o -$(IOBJS) $(LOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS): $(BOBJS) clean: cleanobjs veryclean: cleanobjs