fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Moved various modules related to RB around, into auxil, update Makefile.

Browse Source
This commit is contained in:
Salvatore Filippone
2023-08-29 16:19:56 +02:00
parent 7b45994b70
commit d0cacda995
12 changed files with 448 additions and 317 deletions
Download Patch File Download Diff File Expand all files Collapse all files
README.md
+1
View File
@@ -121,6 +121,7 @@ Salvatore Filippone
Contributors (roughly reverse cronological order):
Dimitri Walther
Andea Di Iorio
Stefano Petrilli
Soren Rasmussen
base/modules/Makefile
+12 -6
View File
@@ -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
base/modules/auxil/psb_d_rb_idx_tree_mod.f90
+128
View File
@@ -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
base/modules/auxil/psb_rb_idx_tree_mod.f90
+49
View File
@@ -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
base/modules/auxil/psb_sort_mod.f90
+2 -1
View File
@@ -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
base/serial/sort/psi_acx_mod.f90 → base/modules/auxil/psi_acx_mod.f90
View File
base/serial/sort/psi_alcx_mod.f90 → base/modules/auxil/psi_alcx_mod.f90
View File
base/serial/sort/psi_lcx_mod.f90 → base/modules/auxil/psi_lcx_mod.f90
View File
base/modules/serial/psb_d_rb_idx_tree_mod.f90
-91
View File
@@ -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
base/modules/serial/psb_rb_idx_tree_mod.f90
-5
View File
@@ -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
base/serial/impl/psb_d_rb_idx_tree_impl.F90
+255 -211
View File
@@ -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
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.
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
if (.not. associated(this%root)) then
this%root => new_node
this%nnz = 1
new_node%is_red = .false.
return
end if
current => this%root
current => this%root
do while (associated(current))
previous => current
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 => current%right
end if
end do
if (idx < previous%idx) then
new_node%parent => previous
previous%left => new_node
if (idx == current%idx) then
current%val = current%val + val
deallocate(new_node)
return
else if (idx < current%idx) then
current => current%left
else
new_node%parent => previous
previous%right => new_node
current => current%right
end if
end do
call psb_d_rb_idx_tree_fix_insertion(this, new_node)
if (idx < previous%idx) then
new_node%parent => previous
previous%left => new_node
else
new_node%parent => previous
previous%right => new_node
end if
this%nnz = this%nnz + 1
call psb_d_rb_idx_tree_fix_insertion(this, new_node)
this%nnz = this%nnz + 1
end subroutine psb_d_rb_idx_tree_insert
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
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'
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
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 (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
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)
! 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
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)
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
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)
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
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)
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
if (this%root%idx == grand_parent%idx) this%root => current
this%root%is_red = .false.
return
end if
end do
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'
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
do i = mat%irp(row_num), mat%irp(row_num + 1) - 1
call tree%insert(mat%ja(i),scalar * mat%val(i))
end do
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
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'
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)
rows = size(trees)
mat%irp(1) = 1
do i=1, rows
mat%irp(i + 1) = mat%irp(i) + trees(i)%nnz
end do
mat%irp(1) = 1
nnz = mat%irp(rows + 1)
call psb_realloc(nnz, mat%val, info)
call psb_realloc(nnz, mat%ja, info)
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
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
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
end subroutine psb_d_rb_idx_tree_merge
base/serial/sort/Makefile
+1 -3
View File
@@ -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