fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/modules/Makefile
 base/modules/psb_c_sort_mod.f90
 base/modules/psb_d_sort_mod.f90
 base/modules/psb_i_sort_mod.f90
 base/modules/psb_s_sort_mod.f90
 base/modules/psb_sort_mod_save.f90
 base/modules/psb_z_sort_mod.f90
 base/serial/aux/psi_acx_mod.f90
 base/serial/aux/psi_alcx_mod.f90
 base/serial/aux/psi_lcx_mod.f90
 base/serial/sort
 base/serial/sort/psb_c_hsort_impl.f90
 base/serial/sort/psb_c_isort_impl.f90
 base/serial/sort/psb_c_msort_impl.f90
 base/serial/sort/psb_c_qsort_impl.f90
 base/serial/sort/psb_d_hsort_impl.f90
 base/serial/sort/psb_d_isort_impl.f90
 base/serial/sort/psb_d_msort_impl.f90
 base/serial/sort/psb_d_qsort_impl.f90
 base/serial/sort/psb_i_hsort_impl.f90
 base/serial/sort/psb_i_isort_impl.f90
 base/serial/sort/psb_i_msort_impl.f90
 base/serial/sort/psb_i_qsort_impl.f90
 base/serial/sort/psb_s_hsort_impl.f90
 base/serial/sort/psb_s_isort_impl.f90
 base/serial/sort/psb_s_msort_impl.f90
 base/serial/sort/psb_s_qsort_impl.f90
 base/serial/sort/psb_z_hsort_impl.f90
 base/serial/sort/psb_z_isort_impl.f90
 base/serial/sort/psb_z_msort_impl.f90
 base/serial/sort/psb_z_qsort_impl.f90
 base/serial/sort/psi_acx_mod.f90
 base/serial/sort/psi_alcx_mod.f90
 base/serial/sort/psi_lcx_mod.f90
 test/pargen/runs/ppde.inp

New sort implementation, put the files in and test they compile.
psblas-3.4-maint
Salvatore Filippone 10 years ago
parent f4e8cf15c1
commit dcd71b9b0f
31 changed files with 22471 additions and 2 deletions
Show Stats Download Patch File Download Diff File

6
base/modules/Makefile
Unescape Escape View File

@ -6,7 +6,8 @@ UTIL_MODS = psb_string_mod.o psb_desc_const_mod.o psb_indx_map_mod.o\
psb_gen_block_map_mod.o psb_list_map_mod.o psb_repl_map_mod.o\ psb_gen_block_map_mod.o psb_list_map_mod.o psb_repl_map_mod.o\
psb_glist_map_mod.o psb_hash_map_mod.o \ psb_glist_map_mod.o psb_hash_map_mod.o \
psb_desc_mod.o psb_sort_mod.o \ psb_desc_mod.o psb_sort_mod.o \
psb_s_serial_mod.o psb_d_serial_mod.o psb_c_serial_mod.o psb_z_serial_mod.o psb_serial_mod.o \ psb_s_serial_mod.o psb_d_serial_mod.o psb_c_serial_mod.o psb_z_serial_mod.o
psb_serial_mod.o \
psb_cd_tools_mod.o psb_i_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\ psb_cd_tools_mod.o psb_i_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\
psb_c_tools_mod.o psb_z_tools_mod.o psb_tools_mod.o \ psb_c_tools_mod.o psb_z_tools_mod.o psb_tools_mod.o \
psb_penv_mod.o $(COMMINT) psb_error_impl.o \ psb_penv_mod.o $(COMMINT) psb_error_impl.o \
@ -25,6 +26,8 @@ UTIL_MODS = psb_string_mod.o psb_desc_const_mod.o psb_indx_map_mod.o\
psi_serial_mod.o \ psi_serial_mod.o \
psi_mod.o psi_i_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o\ psi_mod.o psi_i_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o\
psb_ip_reord_mod.o\ psb_ip_reord_mod.o\
psb_i_sort_mod.o psb_s_sort_mod.o psb_d_sort_mod.o \
psb_c_sort_mod.o psb_z_sort_mod.o
psb_check_mod.o psb_hash_mod.o\ psb_check_mod.o psb_hash_mod.o\
psb_base_mat_mod.o psb_mat_mod.o\ psb_base_mat_mod.o psb_mat_mod.o\
psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_csc_mat_mod.o psb_s_mat_mod.o \ psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_csc_mat_mod.o psb_s_mat_mod.o \
@ -57,6 +60,7 @@ psi_penv_mod.o: psi_comm_buffers_mod.o
psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o: psi_penv_mod.o psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o: psi_penv_mod.o
psb_i_sort_mod.o psb_s_sort_mod.o psb_d_sort_mod.o psb_c_sort_mod.o psb_z_sort_mod.o \
psb_ip_reord_mod.o psi_serial_mod.o psb_sort_mod.o: $(BASIC_MODS) psb_ip_reord_mod.o psi_serial_mod.o psb_sort_mod.o: $(BASIC_MODS)
psb_base_mat_mod.o: psi_serial_mod.o psb_base_mat_mod.o: psi_serial_mod.o
psb_s_base_mat_mod.o psb_d_base_mat_mod.o psb_c_base_mat_mod.o psb_z_base_mat_mod.o: psb_base_mat_mod.o psb_s_base_mat_mod.o psb_d_base_mat_mod.o psb_c_base_mat_mod.o psb_z_base_mat_mod.o: psb_base_mat_mod.o

633
base/modules/psb_c_sort_mod.f90
Unescape Escape View File

@ -0,0 +1,633 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! Sorting routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_c_sort_mod
use psb_const_mod
type psb_c_heap
integer(psb_ipk_) :: last, dir
complex(psb_spk_), allocatable :: keys(:)
contains
procedure, pass(heap) :: init => psb_c_init_heap
procedure, pass(heap) :: howmany => psb_c_howmany
procedure, pass(heap) :: insert => psb_c_insert_heap
procedure, pass(heap) :: get_first => psb_c_heap_get_first
procedure, pass(heap) :: dump => psb_c_dump_heap
procedure, pass(heap) :: free => psb_c_free_heap
end type psb_c_heap
type psb_c_idx_heap
integer(psb_ipk_) :: last, dir
complex(psb_spk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
contains
procedure, pass(heap) :: init => psb_c_idx_init_heap
procedure, pass(heap) :: howmany => psb_c_idx_howmany
procedure, pass(heap) :: insert => psb_c_idx_insert_heap
procedure, pass(heap) :: get_first => psb_c_idx_heap_get_first
procedure, pass(heap) :: dump => psb_c_idx_dump_heap
procedure, pass(heap) :: free => psb_c_idx_free_heap
end type psb_c_idx_heap
interface psb_msort
subroutine psb_cmsort(x,ix,dir,flag)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_cmsort
end interface psb_msort
interface psb_qsort
subroutine psb_cqsort(x,ix,dir,flag)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_cqsort
end interface psb_qsort
interface psb_isort
subroutine psb_cisort(x,ix,dir,flag)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_cisort
end interface psb_isort
interface psb_hsort
subroutine psb_chsort(x,ix,dir,flag)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_chsort
end interface psb_hsort
interface psb_howmany_heap
function psb_c_howmany(heap) result(res)
import
class(psb_c_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_c_howmany
function psb_c_idx_howmany(heap) result(res)
import
class(psb_c_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_c_idx_howmany
end interface psb_howmany_heap
interface psb_init_heap
subroutine psb_c_init_heap(heap,info,dir)
import
class(psb_c_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_c_init_heap
subroutine psb_c_idx_init_heap(heap,info,dir)
import
class(psb_c_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_c_idx_init_heap
end interface psb_init_heap
interface psb_dump_heap
subroutine psb_c_dump_heap(iout,heap,info)
import
class(psb_c_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_c_dump_heap
subroutine psb_dump_c_idx_heap(iout,heap,info)
import
class(psb_c_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_c_idx_heap
end interface psb_dump_heap
interface psb_insert_heap
subroutine psb_c_insert_heap(key,heap,info)
import
complex(psb_spk_), intent(in) :: key
class(psb_c_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_insert_heap
subroutine psb_c_idx_insert_heap(key,index,heap,info)
import
complex(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_c_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_idx_insert_heap
end interface psb_insert_heap
interface psb_heap_get_first
subroutine psb_c_heap_get_first(key,heap,info)
import
class(psb_c_heap), intent(inout) :: heap
complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_heap_get_first
subroutine psb_c_idx_heap_get_first(key,index,heap,info)
import
class(psb_c_idx_heap), intent(inout) :: heap
complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_idx_heap_get_first
end interface psb_heap_get_first
interface
subroutine psi_c_insert_heap(key,last,heap,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
complex(psb_spk_), intent(in) :: key
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_c_insert_heap
end interface
interface
subroutine psi_c_idx_insert_heap(key,index,last,heap,idxs,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
complex(psb_spk_), intent(in) :: key
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: index
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_c_idx_insert_heap
end interface
interface
subroutine psi_c_heap_get_first(key,last,heap,dir,info)
import
implicit none
complex(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_c_heap_get_first
end interface
interface
subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
complex(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_c_idx_heap_get_first
end interface
interface
subroutine psi_clisrx_up(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clisrx_up
subroutine psi_clisrx_dw(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clisrx_dw
subroutine psi_clisr_up(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clisr_up
subroutine psi_clisr_dw(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clisr_dw
subroutine psi_calisrx_up(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calisrx_up
subroutine psi_calisrx_dw(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calisrx_dw
subroutine psi_calisr_up(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calisr_up
subroutine psi_calisr_dw(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calisr_dw
subroutine psi_caisrx_up(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caisrx_up
subroutine psi_caisrx_dw(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caisrx_dw
subroutine psi_caisr_up(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caisr_up
subroutine psi_caisr_dw(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caisr_dw
end interface
interface
subroutine psi_clqsrx_up(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clqsrx_up
subroutine psi_clqsrx_dw(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clqsrx_dw
subroutine psi_clqsr_up(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clqsr_up
subroutine psi_clqsr_dw(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_clqsr_dw
subroutine psi_calqsrx_up(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calqsrx_up
subroutine psi_calqsrx_dw(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calqsrx_dw
subroutine psi_calqsr_up(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calqsr_up
subroutine psi_calqsr_dw(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_calqsr_dw
subroutine psi_caqsrx_up(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caqsrx_up
subroutine psi_caqsrx_dw(n,x,ix)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caqsrx_dw
subroutine psi_caqsr_up(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caqsr_up
subroutine psi_caqsr_dw(n,x)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_caqsr_dw
end interface
interface psb_free_heap
module procedure psb_free_c_heap, psb_free_c_idx_heap
end interface psb_free_heap
contains
subroutine psb_c_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_c_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_asort_up_
endif
select case(heap%dir)
case (psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_'
heap%dir = psb_asort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
return
end subroutine psb_c_init_heap
function psb_c_howmany(heap) result(res)
implicit none
class(psb_scomplex_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_c_howmany
subroutine psb_c_insert_heap(key,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
complex(@FKIND), intent(in) :: key
class(psb_c_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_c_insert_heap(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_c_insert_heap
subroutine psb_c_heap_get_first(key,heap,info)
implicit none
class(psb_c_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
complex(@FKIND), intent(out) :: key
info = psb_success_
call psi_c_heap_get_first(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_c_heap_get_first
subroutine psb_c_dump_heap(iout,heap,info)
implicit none
class(psb_c_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
end if
end subroutine psb_c_dump_heap
subroutine psb_free_c_heap(heap,info)
implicit none
class(psb_c_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_free_c_heap
subroutine psb_c_idx_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_c_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_asort_up_
endif
select case(heap%dir)
case (psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_'
heap%dir = psb_asort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
call psb_ensure_size(psb_heap_resize,heap%idxs,info)
return
end subroutine psb_c_idx_init_heap
function psb_c_idx_howmany(heap) result(res)
implicit none
class(psb_scomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_c_idx_howmany
subroutine psb_c_idx_insert_heap(key,index,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
complex(@FKIND), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_c_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info == psb_success_) &
& call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_c_idx_insert_heap(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_c_idx_insert_heap
subroutine psb_c_idx_heap_get_first(key,index,heap,info)
implicit none
class(psb_c_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
complex(@FKIND), intent(out) :: key
info = psb_success_
call psi_c_idx_heap_get_first(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_c_idx_heap_get_first
subroutine psb_c_idx_dump_heap(iout,heap,info)
implicit none
class(psb_c_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else if ((heap%last > 0).and.((.not.allocated(heap%idxs)).or.&
& (size(heap%idxs)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
write(iout,*) heap%idxs(1:heap%last)
end if
end subroutine psb_c_idx_dump_heap
subroutine psb_free_c_idx_heap(heap,info)
implicit none
class(psb_c_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_c_idx_heap
end module psb_c_sort_mod

589
base/modules/psb_d_sort_mod.f90
Unescape Escape View File

@ -0,0 +1,589 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! Sorting routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_d_sort_mod
use psb_const_mod
type psb_d_heap
integer(psb_ipk_) :: last, dir
real(psb_dpk_), allocatable :: keys(:)
contains
procedure, pass(heap) :: init => psb_d_init_heap
procedure, pass(heap) :: howmany => psb_d_howmany
procedure, pass(heap) :: insert => psb_d_insert_heap
procedure, pass(heap) :: get_first => psb_d_heap_get_first
procedure, pass(heap) :: dump => psb_d_dump_heap
procedure, pass(heap) :: free => psb_d_free_heap
end type psb_d_heap
type psb_d_idx_heap
integer(psb_ipk_) :: last, dir
real(psb_dpk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
contains
procedure, pass(heap) :: init => psb_d_idx_init_heap
procedure, pass(heap) :: howmany => psb_d_idx_howmany
procedure, pass(heap) :: insert => psb_d_idx_insert_heap
procedure, pass(heap) :: get_first => psb_d_idx_heap_get_first
procedure, pass(heap) :: dump => psb_d_idx_dump_heap
procedure, pass(heap) :: free => psb_d_idx_free_heap
end type psb_d_idx_heap
interface psb_msort
subroutine psb_dmsort(x,ix,dir,flag)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_dmsort
end interface psb_msort
interface psb_qsort
subroutine psb_dqsort(x,ix,dir,flag)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_dqsort
end interface psb_qsort
interface psb_isort
subroutine psb_disort(x,ix,dir,flag)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_disort
end interface psb_isort
interface psb_hsort
subroutine psb_dhsort(x,ix,dir,flag)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_dhsort
end interface psb_hsort
interface psb_howmany_heap
function psb_d_howmany(heap) result(res)
import
class(psb_d_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_d_howmany
function psb_d_idx_howmany(heap) result(res)
import
class(psb_d_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_d_idx_howmany
end interface psb_howmany_heap
interface psb_init_heap
subroutine psb_d_init_heap(heap,info,dir)
import
class(psb_d_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_d_init_heap
subroutine psb_d_idx_init_heap(heap,info,dir)
import
class(psb_d_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_d_idx_init_heap
end interface psb_init_heap
interface psb_dump_heap
subroutine psb_d_dump_heap(iout,heap,info)
import
class(psb_d_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_d_dump_heap
subroutine psb_dump_d_idx_heap(iout,heap,info)
import
class(psb_d_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_d_idx_heap
end interface psb_dump_heap
interface psb_insert_heap
subroutine psb_d_insert_heap(key,heap,info)
import
real(psb_dpk_), intent(in) :: key
class(psb_d_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_insert_heap
subroutine psb_d_idx_insert_heap(key,index,heap,info)
import
real(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_d_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_idx_insert_heap
end interface psb_insert_heap
interface psb_heap_get_first
subroutine psb_d_heap_get_first(key,heap,info)
import
class(psb_d_heap), intent(inout) :: heap
real(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_heap_get_first
subroutine psb_d_idx_heap_get_first(key,index,heap,info)
import
class(psb_d_idx_heap), intent(inout) :: heap
real(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_idx_heap_get_first
end interface psb_heap_get_first
interface
subroutine psi_d_insert_heap(key,last,heap,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
real(psb_dpk_), intent(in) :: key
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_d_insert_heap
end interface
interface
subroutine psi_d_idx_insert_heap(key,index,last,heap,idxs,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
real(psb_dpk_), intent(in) :: key
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: index
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_d_idx_insert_heap
end interface
interface
subroutine psi_d_heap_get_first(key,last,heap,dir,info)
import
implicit none
real(psb_dpk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_d_heap_get_first
end interface
interface
subroutine psi_d_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
real(psb_dpk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_d_idx_heap_get_first
end interface
interface
subroutine psi_disrx_up(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_disrx_up
subroutine psi_disrx_dw(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_disrx_dw
subroutine psi_disr_up(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_disr_up
subroutine psi_disr_dw(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_disr_dw
subroutine psi_daisrx_up(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daisrx_up
subroutine psi_daisrx_dw(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daisrx_dw
subroutine psi_daisr_up(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daisr_up
subroutine psi_daisr_dw(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daisr_dw
end interface
interface
subroutine psi_dqsrx_up(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_dqsrx_up
subroutine psi_dqsrx_dw(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_dqsrx_dw
subroutine psi_dqsr_up(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_dqsr_up
subroutine psi_dqsr_dw(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_dqsr_dw
subroutine psi_daqsrx_up(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daqsrx_up
subroutine psi_daqsrx_dw(n,x,ix)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daqsrx_dw
subroutine psi_daqsr_up(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daqsr_up
subroutine psi_daqsr_dw(n,x)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_daqsr_dw
end interface
interface psb_free_heap
module procedure psb_free_d_heap, psb_free_d_idx_heap
end interface psb_free_heap
contains
subroutine psb_d_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_d_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
return
end subroutine psb_d_init_heap
function psb_d_howmany(heap) result(res)
implicit none
class(psb_scomplex_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_d_howmany
subroutine psb_d_insert_heap(key,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
real(@FKIND), intent(in) :: key
class(psb_d_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_d_insert_heap(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_d_insert_heap
subroutine psb_d_heap_get_first(key,heap,info)
implicit none
class(psb_d_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
real(@FKIND), intent(out) :: key
info = psb_success_
call psi_d_heap_get_first(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_d_heap_get_first
subroutine psb_d_dump_heap(iout,heap,info)
implicit none
class(psb_d_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
end if
end subroutine psb_d_dump_heap
subroutine psb_free_d_heap(heap,info)
implicit none
class(psb_d_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_free_d_heap
subroutine psb_d_idx_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_d_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
call psb_ensure_size(psb_heap_resize,heap%idxs,info)
return
end subroutine psb_d_idx_init_heap
function psb_d_idx_howmany(heap) result(res)
implicit none
class(psb_scomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_d_idx_howmany
subroutine psb_d_idx_insert_heap(key,index,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
real(@FKIND), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_d_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info == psb_success_) &
& call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_d_idx_insert_heap(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_d_idx_insert_heap
subroutine psb_d_idx_heap_get_first(key,index,heap,info)
implicit none
class(psb_d_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
real(@FKIND), intent(out) :: key
info = psb_success_
call psi_d_idx_heap_get_first(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_d_idx_heap_get_first
subroutine psb_d_idx_dump_heap(iout,heap,info)
implicit none
class(psb_d_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else if ((heap%last > 0).and.((.not.allocated(heap%idxs)).or.&
& (size(heap%idxs)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
write(iout,*) heap%idxs(1:heap%last)
end if
end subroutine psb_d_idx_dump_heap
subroutine psb_free_d_idx_heap(heap,info)
implicit none
class(psb_d_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_d_idx_heap
end module psb_d_sort_mod

630
base/modules/psb_i_sort_mod.f90
Unescape Escape View File

@ -0,0 +1,630 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! Sorting routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_i_sort_mod
use psb_const_mod
interface psb_iblsrch
function psb_iblsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_iblsrch
end interface psb_iblsrch
interface psb_ibsrch
function psb_ibsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_ibsrch
end interface psb_ibsrch
interface psb_issrch
function psb_issrch(key,n,v) result(ipos)
import :: psb_ipk_
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_issrch
end interface psb_issrch
interface psb_isaperm
logical function psb_isaperm(n,eip)
import :: psb_ipk_
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: eip(n)
end function psb_isaperm
end interface psb_isaperm
interface psb_msort_unique
subroutine psb_imsort_u(x,nout,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_imsort_u
end interface psb_msort_unique
type psb_i_heap
integer(psb_ipk_) :: last, dir
integer(psb_ipk_), allocatable :: keys(:)
contains
procedure, pass(heap) :: init => psb_i_init_heap
procedure, pass(heap) :: howmany => psb_i_howmany
procedure, pass(heap) :: insert => psb_i_insert_heap
procedure, pass(heap) :: get_first => psb_i_heap_get_first
procedure, pass(heap) :: dump => psb_i_dump_heap
procedure, pass(heap) :: free => psb_i_free_heap
end type psb_i_heap
type psb_i_idx_heap
integer(psb_ipk_) :: last, dir
integer(psb_ipk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
contains
procedure, pass(heap) :: init => psb_i_idx_init_heap
procedure, pass(heap) :: howmany => psb_i_idx_howmany
procedure, pass(heap) :: insert => psb_i_idx_insert_heap
procedure, pass(heap) :: get_first => psb_i_idx_heap_get_first
procedure, pass(heap) :: dump => psb_i_idx_dump_heap
procedure, pass(heap) :: free => psb_i_idx_free_heap
end type psb_i_idx_heap
interface psb_msort
subroutine psb_imsort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_imsort
end interface psb_msort
interface psb_qsort
subroutine psb_iqsort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_iqsort
end interface psb_qsort
interface psb_isort
subroutine psb_iisort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_iisort
end interface psb_isort
interface psb_hsort
subroutine psb_ihsort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_ihsort
end interface psb_hsort
interface psb_howmany_heap
function psb_i_howmany(heap) result(res)
import
class(psb_i_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_i_howmany
function psb_i_idx_howmany(heap) result(res)
import
class(psb_i_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_i_idx_howmany
end interface psb_howmany_heap
interface psb_init_heap
subroutine psb_i_init_heap(heap,info,dir)
import
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_i_init_heap
subroutine psb_i_idx_init_heap(heap,info,dir)
import
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_i_idx_init_heap
end interface psb_init_heap
interface psb_dump_heap
subroutine psb_i_dump_heap(iout,heap,info)
import
class(psb_i_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_i_dump_heap
subroutine psb_dump_i_idx_heap(iout,heap,info)
import
class(psb_i_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_i_idx_heap
end interface psb_dump_heap
interface psb_insert_heap
subroutine psb_i_insert_heap(key,heap,info)
import
integer(psb_ipk_), intent(in) :: key
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_i_insert_heap
subroutine psb_i_idx_insert_heap(key,index,heap,info)
import
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_i_idx_insert_heap
end interface psb_insert_heap
interface psb_heap_get_first
subroutine psb_i_heap_get_first(key,heap,info)
import
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: info
end subroutine psb_i_heap_get_first
subroutine psb_i_idx_heap_get_first(key,index,heap,info)
import
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(out) :: info
end subroutine psb_i_idx_heap_get_first
end interface psb_heap_get_first
interface
subroutine psi_i_insert_heap(key,last,heap,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_insert_heap
end interface
interface
subroutine psi_i_idx_insert_heap(key,index,last,heap,idxs,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: index
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_idx_insert_heap
end interface
interface
subroutine psi_i_heap_get_first(key,last,heap,dir,info)
import
implicit none
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_heap_get_first
end interface
interface
subroutine psi_i_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_idx_heap_get_first
end interface
interface
subroutine psi_iisrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisrx_up
subroutine psi_iisrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisrx_dw
subroutine psi_iisr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisr_up
subroutine psi_iisr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisr_dw
subroutine psi_iaisrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisrx_up
subroutine psi_iaisrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisrx_dw
subroutine psi_iaisr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisr_up
subroutine psi_iaisr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisr_dw
end interface
interface
subroutine psi_iqsrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsrx_up
subroutine psi_iqsrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsrx_dw
subroutine psi_iqsr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsr_up
subroutine psi_iqsr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsr_dw
subroutine psi_iaqsrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsrx_up
subroutine psi_iaqsrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsrx_dw
subroutine psi_iaqsr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsr_up
subroutine psi_iaqsr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsr_dw
end interface
interface psb_free_heap
module procedure psb_free_i_heap, psb_free_i_idx_heap
end interface psb_free_heap
contains
subroutine psb_i_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
return
end subroutine psb_i_init_heap
function psb_i_howmany(heap) result(res)
implicit none
class(psb_scomplex_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_i_howmany
subroutine psb_i_insert_heap(key,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
integer(@FKIND), intent(in) :: key
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_i_insert_heap(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_i_insert_heap
subroutine psb_i_heap_get_first(key,heap,info)
implicit none
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
integer(@FKIND), intent(out) :: key
info = psb_success_
call psi_i_heap_get_first(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_i_heap_get_first
subroutine psb_i_dump_heap(iout,heap,info)
implicit none
class(psb_i_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
end if
end subroutine psb_i_dump_heap
subroutine psb_free_i_heap(heap,info)
implicit none
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_free_i_heap
subroutine psb_i_idx_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
call psb_ensure_size(psb_heap_resize,heap%idxs,info)
return
end subroutine psb_i_idx_init_heap
function psb_i_idx_howmany(heap) result(res)
implicit none
class(psb_scomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_i_idx_howmany
subroutine psb_i_idx_insert_heap(key,index,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
integer(@FKIND), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info == psb_success_) &
& call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_i_idx_insert_heap(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_i_idx_insert_heap
subroutine psb_i_idx_heap_get_first(key,index,heap,info)
implicit none
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
integer(@FKIND), intent(out) :: key
info = psb_success_
call psi_i_idx_heap_get_first(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_i_idx_heap_get_first
subroutine psb_i_idx_dump_heap(iout,heap,info)
implicit none
class(psb_i_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else if ((heap%last > 0).and.((.not.allocated(heap%idxs)).or.&
& (size(heap%idxs)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
write(iout,*) heap%idxs(1:heap%last)
end if
end subroutine psb_i_idx_dump_heap
subroutine psb_free_i_idx_heap(heap,info)
implicit none
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_i_idx_heap
end module psb_i_sort_mod

589
base/modules/psb_s_sort_mod.f90
Unescape Escape View File

@ -0,0 +1,589 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! Sorting routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_s_sort_mod
use psb_const_mod
type psb_s_heap
integer(psb_ipk_) :: last, dir
real(psb_spk_), allocatable :: keys(:)
contains
procedure, pass(heap) :: init => psb_s_init_heap
procedure, pass(heap) :: howmany => psb_s_howmany
procedure, pass(heap) :: insert => psb_s_insert_heap
procedure, pass(heap) :: get_first => psb_s_heap_get_first
procedure, pass(heap) :: dump => psb_s_dump_heap
procedure, pass(heap) :: free => psb_s_free_heap
end type psb_s_heap
type psb_s_idx_heap
integer(psb_ipk_) :: last, dir
real(psb_spk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
contains
procedure, pass(heap) :: init => psb_s_idx_init_heap
procedure, pass(heap) :: howmany => psb_s_idx_howmany
procedure, pass(heap) :: insert => psb_s_idx_insert_heap
procedure, pass(heap) :: get_first => psb_s_idx_heap_get_first
procedure, pass(heap) :: dump => psb_s_idx_dump_heap
procedure, pass(heap) :: free => psb_s_idx_free_heap
end type psb_s_idx_heap
interface psb_msort
subroutine psb_smsort(x,ix,dir,flag)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_smsort
end interface psb_msort
interface psb_qsort
subroutine psb_sqsort(x,ix,dir,flag)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_sqsort
end interface psb_qsort
interface psb_isort
subroutine psb_sisort(x,ix,dir,flag)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_sisort
end interface psb_isort
interface psb_hsort
subroutine psb_shsort(x,ix,dir,flag)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_shsort
end interface psb_hsort
interface psb_howmany_heap
function psb_s_howmany(heap) result(res)
import
class(psb_s_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_s_howmany
function psb_s_idx_howmany(heap) result(res)
import
class(psb_s_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_s_idx_howmany
end interface psb_howmany_heap
interface psb_init_heap
subroutine psb_s_init_heap(heap,info,dir)
import
class(psb_s_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_s_init_heap
subroutine psb_s_idx_init_heap(heap,info,dir)
import
class(psb_s_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_s_idx_init_heap
end interface psb_init_heap
interface psb_dump_heap
subroutine psb_s_dump_heap(iout,heap,info)
import
class(psb_s_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_s_dump_heap
subroutine psb_dump_s_idx_heap(iout,heap,info)
import
class(psb_s_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_s_idx_heap
end interface psb_dump_heap
interface psb_insert_heap
subroutine psb_s_insert_heap(key,heap,info)
import
real(psb_spk_), intent(in) :: key
class(psb_s_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_insert_heap
subroutine psb_s_idx_insert_heap(key,index,heap,info)
import
real(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_s_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_idx_insert_heap
end interface psb_insert_heap
interface psb_heap_get_first
subroutine psb_s_heap_get_first(key,heap,info)
import
class(psb_s_heap), intent(inout) :: heap
real(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_heap_get_first
subroutine psb_s_idx_heap_get_first(key,index,heap,info)
import
class(psb_s_idx_heap), intent(inout) :: heap
real(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_idx_heap_get_first
end interface psb_heap_get_first
interface
subroutine psi_s_insert_heap(key,last,heap,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
real(psb_spk_), intent(in) :: key
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_s_insert_heap
end interface
interface
subroutine psi_s_idx_insert_heap(key,index,last,heap,idxs,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
real(psb_spk_), intent(in) :: key
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: index
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_s_idx_insert_heap
end interface
interface
subroutine psi_s_heap_get_first(key,last,heap,dir,info)
import
implicit none
real(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_s_heap_get_first
end interface
interface
subroutine psi_s_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
real(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_s_idx_heap_get_first
end interface
interface
subroutine psi_sisrx_up(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sisrx_up
subroutine psi_sisrx_dw(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sisrx_dw
subroutine psi_sisr_up(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sisr_up
subroutine psi_sisr_dw(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sisr_dw
subroutine psi_saisrx_up(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saisrx_up
subroutine psi_saisrx_dw(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saisrx_dw
subroutine psi_saisr_up(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saisr_up
subroutine psi_saisr_dw(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saisr_dw
end interface
interface
subroutine psi_sqsrx_up(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sqsrx_up
subroutine psi_sqsrx_dw(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sqsrx_dw
subroutine psi_sqsr_up(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sqsr_up
subroutine psi_sqsr_dw(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_sqsr_dw
subroutine psi_saqsrx_up(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saqsrx_up
subroutine psi_saqsrx_dw(n,x,ix)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saqsrx_dw
subroutine psi_saqsr_up(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saqsr_up
subroutine psi_saqsr_dw(n,x)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_saqsr_dw
end interface
interface psb_free_heap
module procedure psb_free_s_heap, psb_free_s_idx_heap
end interface psb_free_heap
contains
subroutine psb_s_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_s_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
return
end subroutine psb_s_init_heap
function psb_s_howmany(heap) result(res)
implicit none
class(psb_scomplex_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_s_howmany
subroutine psb_s_insert_heap(key,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
real(@FKIND), intent(in) :: key
class(psb_s_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_s_insert_heap(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_s_insert_heap
subroutine psb_s_heap_get_first(key,heap,info)
implicit none
class(psb_s_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
real(@FKIND), intent(out) :: key
info = psb_success_
call psi_s_heap_get_first(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_s_heap_get_first
subroutine psb_s_dump_heap(iout,heap,info)
implicit none
class(psb_s_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
end if
end subroutine psb_s_dump_heap
subroutine psb_free_s_heap(heap,info)
implicit none
class(psb_s_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_free_s_heap
subroutine psb_s_idx_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_s_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
call psb_ensure_size(psb_heap_resize,heap%idxs,info)
return
end subroutine psb_s_idx_init_heap
function psb_s_idx_howmany(heap) result(res)
implicit none
class(psb_scomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_s_idx_howmany
subroutine psb_s_idx_insert_heap(key,index,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
real(@FKIND), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_s_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info == psb_success_) &
& call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_s_idx_insert_heap(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_s_idx_insert_heap
subroutine psb_s_idx_heap_get_first(key,index,heap,info)
implicit none
class(psb_s_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
real(@FKIND), intent(out) :: key
info = psb_success_
call psi_s_idx_heap_get_first(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_s_idx_heap_get_first
subroutine psb_s_idx_dump_heap(iout,heap,info)
implicit none
class(psb_s_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else if ((heap%last > 0).and.((.not.allocated(heap%idxs)).or.&
& (size(heap%idxs)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
write(iout,*) heap%idxs(1:heap%last)
end if
end subroutine psb_s_idx_dump_heap
subroutine psb_free_s_idx_heap(heap,info)
implicit none
class(psb_s_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_s_idx_heap
end module psb_s_sort_mod

741
base/modules/psb_sort_mod_save.f90
Unescape Escape View File

@ -0,0 +1,741 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort and quicksort routines are implemented in the
! serial/aux directory
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_sort_mod
use psb_const_mod
type psb_int_heap
integer(psb_ipk_) :: last, dir
integer(psb_ipk_), allocatable :: keys(:)
end type psb_int_heap
type psb_int_idx_heap
integer(psb_ipk_) :: last, dir
integer(psb_ipk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
end type psb_int_idx_heap
type psb_sreal_idx_heap
integer(psb_ipk_) :: last, dir
real(psb_spk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
end type psb_sreal_idx_heap
type psb_dreal_idx_heap
integer(psb_ipk_) :: last, dir
real(psb_dpk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
end type psb_dreal_idx_heap
type psb_scomplex_idx_heap
integer(psb_ipk_) :: last, dir
complex(psb_spk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
end type psb_scomplex_idx_heap
type psb_dcomplex_idx_heap
integer(psb_ipk_) :: last, dir
complex(psb_dpk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
end type psb_dcomplex_idx_heap
interface psb_iblsrch
function psb_iblsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_iblsrch
end interface
interface psb_ibsrch
function psb_ibsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_ibsrch
end interface
interface psb_issrch
function psb_issrch(key,n,v) result(ipos)
import :: psb_ipk_
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_issrch
end interface
interface psb_isaperm
logical function psb_isaperm(n,eip)
import :: psb_ipk_
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: eip(n)
end function psb_isaperm
end interface
interface psb_msort
subroutine imsort(x,ix,dir,flag)
import :: psb_ipk_
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine imsort
subroutine smsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine smsort
subroutine dmsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine dmsort
subroutine camsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine camsort
subroutine zamsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine zamsort
end interface
interface psb_msort_unique
subroutine imsort_u(x,nout,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine imsort_u
end interface
interface psb_qsort
subroutine iqsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine iqsort
subroutine sqsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine sqsort
subroutine dqsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine dqsort
subroutine cqsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine cqsort
subroutine zqsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine zqsort
end interface
interface psb_hsort
subroutine ihsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine ihsort
subroutine shsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine shsort
subroutine dhsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine dhsort
subroutine chsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine chsort
subroutine zhsort(x,ix,dir,flag)
import :: psb_ipk_, psb_spk_, psb_dpk_
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine zhsort
end interface
interface psb_howmany_heap
function psb_howmany_int_heap(heap)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_int_heap
type(psb_int_heap), intent(in) :: heap
integer(psb_ipk_) :: psb_howmany_int_heap
end function psb_howmany_int_heap
function psb_howmany_sreal_idx_heap(heap)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_sreal_idx_heap
type(psb_sreal_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: psb_howmany_sreal_idx_heap
end function psb_howmany_sreal_idx_heap
function psb_howmany_dreal_idx_heap(heap)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_dreal_idx_heap
type(psb_dreal_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: psb_howmany_dreal_idx_heap
end function psb_howmany_dreal_idx_heap
function psb_howmany_int_idx_heap(heap)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_int_idx_heap
type(psb_int_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: psb_howmany_int_idx_heap
end function psb_howmany_int_idx_heap
function psb_howmany_scomplex_idx_heap(heap)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_scomplex_idx_heap
type(psb_scomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: psb_howmany_scomplex_idx_heap
end function psb_howmany_scomplex_idx_heap
function psb_howmany_dcomplex_idx_heap(heap)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_dcomplex_idx_heap
type(psb_dcomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: psb_howmany_dcomplex_idx_heap
end function psb_howmany_dcomplex_idx_heap
end interface
interface psb_init_heap
subroutine psb_init_int_heap(heap,info,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_int_heap
type(psb_int_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_init_int_heap
subroutine psb_init_sreal_idx_heap(heap,info,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_sreal_idx_heap
type(psb_sreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_init_sreal_idx_heap
subroutine psb_init_int_idx_heap(heap,info,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_int_idx_heap
type(psb_int_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_init_int_idx_heap
subroutine psb_init_scomplex_idx_heap(heap,info,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_scomplex_idx_heap
type(psb_scomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_init_scomplex_idx_heap
subroutine psb_init_dcomplex_idx_heap(heap,info,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_dcomplex_idx_heap
type(psb_dcomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_init_dcomplex_idx_heap
subroutine psb_init_dreal_idx_heap(heap,info,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_dreal_idx_heap
type(psb_dreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_init_dreal_idx_heap
end interface
interface psb_dump_heap
subroutine psb_dump_int_heap(iout,heap,info)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_int_heap
type(psb_int_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_int_heap
subroutine psb_dump_sreal_idx_heap(iout,heap,info)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_sreal_idx_heap
type(psb_sreal_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_sreal_idx_heap
subroutine psb_dump_dreal_idx_heap(iout,heap,info)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_dreal_idx_heap
type(psb_dreal_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_dreal_idx_heap
subroutine psb_dump_int_idx_heap(iout,heap,info)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_int_idx_heap
type(psb_int_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_int_idx_heap
subroutine psb_dump_scomplex_idx_heap(iout,heap,info)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_scomplex_idx_heap
type(psb_scomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_scomplex_idx_heap
subroutine psb_dump_dcomplex_idx_heap(iout,heap,info)
import :: psb_ipk_, psb_spk_, psb_dpk_
import :: psb_dcomplex_idx_heap
type(psb_dcomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_dcomplex_idx_heap
end interface
interface psb_insert_heap
subroutine psb_insert_int_heap(key,heap,info)
import :: psb_int_heap, psb_ipk_
integer(psb_ipk_), intent(in) :: key
type(psb_int_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_insert_int_heap
subroutine psb_insert_int_idx_heap(key,index,heap,info)
import :: psb_dpk_, psb_int_idx_heap, psb_ipk_
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
type(psb_int_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_insert_int_idx_heap
subroutine psb_insert_sreal_idx_heap(key,index,heap,info)
import :: psb_spk_, psb_sreal_idx_heap, psb_ipk_
real(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
type(psb_sreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_insert_sreal_idx_heap
subroutine psb_insert_dreal_idx_heap(key,index,heap,info)
import :: psb_dpk_, psb_dreal_idx_heap, psb_ipk_
real(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
type(psb_dreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_insert_dreal_idx_heap
subroutine psb_insert_scomplex_idx_heap(key,index,heap,info)
import :: psb_spk_, psb_scomplex_idx_heap, psb_ipk_
complex(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
type(psb_scomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_insert_scomplex_idx_heap
subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info)
import :: psb_dpk_, psb_dcomplex_idx_heap, psb_ipk_
complex(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
type(psb_dcomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_insert_dcomplex_idx_heap
end interface
interface psb_heap_get_first
subroutine psb_int_heap_get_first(key,heap,info)
import :: psb_int_heap, psb_ipk_
type(psb_int_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: key,info
end subroutine psb_int_heap_get_first
subroutine psb_int_idx_heap_get_first(key,index,heap,info)
import :: psb_int_idx_heap, psb_ipk_
type(psb_int_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(out) :: key
end subroutine psb_int_idx_heap_get_first
subroutine psb_sreal_idx_heap_get_first(key,index,heap,info)
import :: psb_spk_, psb_sreal_idx_heap, psb_ipk_
type(psb_sreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
real(psb_spk_), intent(out) :: key
end subroutine psb_sreal_idx_heap_get_first
subroutine psb_dreal_idx_heap_get_first(key,index,heap,info)
import :: psb_dpk_, psb_dreal_idx_heap, psb_ipk_
type(psb_dreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
real(psb_dpk_), intent(out) :: key
end subroutine psb_dreal_idx_heap_get_first
subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info)
import :: psb_spk_, psb_scomplex_idx_heap, psb_ipk_
type(psb_scomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
complex(psb_spk_), intent(out) :: key
end subroutine psb_scomplex_idx_heap_get_first
subroutine psb_dcomplex_idx_heap_get_first(key,index,heap,info)
import :: psb_dpk_, psb_dcomplex_idx_heap, psb_ipk_
type(psb_dcomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
complex(psb_dpk_), intent(out) :: key
end subroutine psb_dcomplex_idx_heap_get_first
end interface
interface
subroutine psi_insert_int_heap(key,last,heap,dir,info)
import :: psb_ipk_
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key,dir
integer(psb_ipk_), intent(inout) :: heap(:),last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_int_heap
end interface
interface
subroutine psi_int_heap_get_first(key,last,heap,dir,info)
import :: psb_ipk_
implicit none
integer(psb_ipk_), intent(inout) :: key,last
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_int_heap_get_first
end interface
interface
subroutine psi_insert_real_heap(key,last,heap,dir,info)
import :: psb_spk_, psb_ipk_
real(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_real_heap
end interface
interface
subroutine psi_real_heap_get_first(key,last,heap,dir,info)
import :: psb_spk_, psb_ipk_
real(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_real_heap_get_first
end interface
interface
subroutine psi_insert_double_heap(key,last,heap,dir,info)
import :: psb_dpk_, psb_ipk_
real(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_double_heap
end interface
interface
subroutine psi_double_heap_get_first(key,last,heap,dir,info)
import :: psb_dpk_, psb_ipk_
real(psb_dpk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_double_heap_get_first
end interface
interface
subroutine psi_insert_scomplex_heap(key,last,heap,dir,info)
import :: psb_spk_, psb_ipk_
complex(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_scomplex_heap
end interface
interface
subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info)
import :: psb_spk_, psb_ipk_
complex(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_scomplex_heap_get_first
end interface
interface
subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info)
import :: psb_dpk_, psb_ipk_
complex(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_dcomplex_heap
end interface
interface
subroutine psi_dcomplex_heap_get_first(key,last,heap,dir,info)
import :: psb_dpk_, psb_ipk_
complex(psb_dpk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dcomplex_heap_get_first
end interface
interface
subroutine psi_insert_int_idx_heap(key,index,last,heap,idxs,dir,info)
import :: psb_ipk_
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
integer(psb_ipk_), intent(inout) :: heap(:),last
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_int_idx_heap
end interface
interface
subroutine psi_int_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import :: psb_ipk_
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(out) :: key
end subroutine psi_int_idx_heap_get_first
end interface
interface
subroutine psi_insert_sreal_idx_heap(key,index,last,heap,idxs,dir,info)
import :: psb_spk_, psb_ipk_
real(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_sreal_idx_heap
end interface
interface
subroutine psi_sreal_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import :: psb_spk_, psb_ipk_
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(out) :: key
end subroutine psi_sreal_idx_heap_get_first
end interface
interface
subroutine psi_insert_dreal_idx_heap(key,index,last,heap,idxs,dir,info)
import :: psb_dpk_, psb_ipk_
real(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_dreal_idx_heap
end interface
interface
subroutine psi_dreal_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import :: psb_dpk_, psb_ipk_
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(out) :: key
end subroutine psi_dreal_idx_heap_get_first
end interface
interface
subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info)
import :: psb_spk_, psb_ipk_
complex(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_scomplex_idx_heap
end interface
interface
subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import :: psb_spk_, psb_ipk_
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(out) :: key
end subroutine psi_scomplex_idx_heap_get_first
end interface
interface
subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info)
import :: psb_dpk_, psb_ipk_
complex(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_insert_dcomplex_idx_heap
end interface
interface
subroutine psi_dcomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import :: psb_dpk_, psb_ipk_
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
complex(psb_dpk_), intent(out) :: key
end subroutine psi_dcomplex_idx_heap_get_first
end interface
interface psb_free_heap
module procedure psb_free_int_heap, psb_free_int_idx_heap,&
& psb_free_sreal_idx_heap, psb_free_scomplex_idx_heap, &
& psb_free_dreal_idx_heap, psb_free_dcomplex_idx_heap
end interface
contains
subroutine psb_free_int_heap(heap,info)
implicit none
type(psb_int_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_free_int_heap
subroutine psb_free_sreal_idx_heap(heap,info)
implicit none
type(psb_sreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_sreal_idx_heap
subroutine psb_free_dreal_idx_heap(heap,info)
implicit none
type(psb_dreal_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_dreal_idx_heap
subroutine psb_free_int_idx_heap(heap,info)
implicit none
type(psb_int_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_int_idx_heap
subroutine psb_free_scomplex_idx_heap(heap,info)
implicit none
type(psb_scomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_scomplex_idx_heap
subroutine psb_free_dcomplex_idx_heap(heap,info)
implicit none
type(psb_dcomplex_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_dcomplex_idx_heap
end module psb_sort_mod

633
base/modules/psb_z_sort_mod.f90
Unescape Escape View File

@ -0,0 +1,633 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! Sorting routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_z_sort_mod
use psb_const_mod
type psb_z_heap
integer(psb_ipk_) :: last, dir
complex(psb_dpk_), allocatable :: keys(:)
contains
procedure, pass(heap) :: init => psb_z_init_heap
procedure, pass(heap) :: howmany => psb_z_howmany
procedure, pass(heap) :: insert => psb_z_insert_heap
procedure, pass(heap) :: get_first => psb_z_heap_get_first
procedure, pass(heap) :: dump => psb_z_dump_heap
procedure, pass(heap) :: free => psb_z_free_heap
end type psb_z_heap
type psb_z_idx_heap
integer(psb_ipk_) :: last, dir
complex(psb_dpk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
contains
procedure, pass(heap) :: init => psb_z_idx_init_heap
procedure, pass(heap) :: howmany => psb_z_idx_howmany
procedure, pass(heap) :: insert => psb_z_idx_insert_heap
procedure, pass(heap) :: get_first => psb_z_idx_heap_get_first
procedure, pass(heap) :: dump => psb_z_idx_dump_heap
procedure, pass(heap) :: free => psb_z_idx_free_heap
end type psb_z_idx_heap
interface psb_msort
subroutine psb_zmsort(x,ix,dir,flag)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_zmsort
end interface psb_msort
interface psb_qsort
subroutine psb_zqsort(x,ix,dir,flag)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_zqsort
end interface psb_qsort
interface psb_isort
subroutine psb_zisort(x,ix,dir,flag)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_zisort
end interface psb_isort
interface psb_hsort
subroutine psb_zhsort(x,ix,dir,flag)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_zhsort
end interface psb_hsort
interface psb_howmany_heap
function psb_z_howmany(heap) result(res)
import
class(psb_z_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_z_howmany
function psb_z_idx_howmany(heap) result(res)
import
class(psb_z_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
end function psb_z_idx_howmany
end interface psb_howmany_heap
interface psb_init_heap
subroutine psb_z_init_heap(heap,info,dir)
import
class(psb_z_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_z_init_heap
subroutine psb_z_idx_init_heap(heap,info,dir)
import
class(psb_z_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
end subroutine psb_z_idx_init_heap
end interface psb_init_heap
interface psb_dump_heap
subroutine psb_z_dump_heap(iout,heap,info)
import
class(psb_z_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_z_dump_heap
subroutine psb_dump_z_idx_heap(iout,heap,info)
import
class(psb_z_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
end subroutine psb_dump_z_idx_heap
end interface psb_dump_heap
interface psb_insert_heap
subroutine psb_z_insert_heap(key,heap,info)
import
complex(psb_dpk_), intent(in) :: key
class(psb_z_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_insert_heap
subroutine psb_z_idx_insert_heap(key,index,heap,info)
import
complex(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_z_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_idx_insert_heap
end interface psb_insert_heap
interface psb_heap_get_first
subroutine psb_z_heap_get_first(key,heap,info)
import
class(psb_z_heap), intent(inout) :: heap
complex(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_heap_get_first
subroutine psb_z_idx_heap_get_first(key,index,heap,info)
import
class(psb_z_idx_heap), intent(inout) :: heap
complex(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_idx_heap_get_first
end interface psb_heap_get_first
interface
subroutine psi_z_insert_heap(key,last,heap,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
complex(psb_dpk_), intent(in) :: key
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_z_insert_heap
end interface
interface
subroutine psi_z_idx_insert_heap(key,index,last,heap,idxs,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
complex(psb_dpk_), intent(in) :: key
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: index
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_z_idx_insert_heap
end interface
interface
subroutine psi_z_heap_get_first(key,last,heap,dir,info)
import
implicit none
complex(psb_dpk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_z_heap_get_first
end interface
interface
subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
complex(psb_dpk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_z_idx_heap_get_first
end interface
interface
subroutine psi_zlisrx_up(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlisrx_up
subroutine psi_zlisrx_dw(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlisrx_dw
subroutine psi_zlisr_up(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlisr_up
subroutine psi_zlisr_dw(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlisr_dw
subroutine psi_zalisrx_up(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalisrx_up
subroutine psi_zalisrx_dw(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalisrx_dw
subroutine psi_zalisr_up(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalisr_up
subroutine psi_zalisr_dw(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalisr_dw
subroutine psi_zaisrx_up(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaisrx_up
subroutine psi_zaisrx_dw(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaisrx_dw
subroutine psi_zaisr_up(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaisr_up
subroutine psi_zaisr_dw(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaisr_dw
end interface
interface
subroutine psi_zlqsrx_up(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlqsrx_up
subroutine psi_zlqsrx_dw(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlqsrx_dw
subroutine psi_zlqsr_up(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlqsr_up
subroutine psi_zlqsr_dw(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zlqsr_dw
subroutine psi_zalqsrx_up(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalqsrx_up
subroutine psi_zalqsrx_dw(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalqsrx_dw
subroutine psi_zalqsr_up(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalqsr_up
subroutine psi_zalqsr_dw(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zalqsr_dw
subroutine psi_zaqsrx_up(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaqsrx_up
subroutine psi_zaqsrx_dw(n,x,ix)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaqsrx_dw
subroutine psi_zaqsr_up(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaqsr_up
subroutine psi_zaqsr_dw(n,x)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_zaqsr_dw
end interface
interface psb_free_heap
module procedure psb_free_z_heap, psb_free_z_idx_heap
end interface psb_free_heap
contains
subroutine psb_z_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_z_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_asort_up_
endif
select case(heap%dir)
case (psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_'
heap%dir = psb_asort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
return
end subroutine psb_z_init_heap
function psb_z_howmany(heap) result(res)
implicit none
class(psb_scomplex_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_z_howmany
subroutine psb_z_insert_heap(key,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
complex(@FKIND), intent(in) :: key
class(psb_z_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_z_insert_heap(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_z_insert_heap
subroutine psb_z_heap_get_first(key,heap,info)
implicit none
class(psb_z_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
complex(@FKIND), intent(out) :: key
info = psb_success_
call psi_z_heap_get_first(key,index,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_z_heap_get_first
subroutine psb_z_dump_heap(iout,heap,info)
implicit none
class(psb_z_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
end if
end subroutine psb_z_dump_heap
subroutine psb_free_z_heap(heap,info)
implicit none
class(psb_z_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_free_z_heap
subroutine psb_z_idx_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_z_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_asort_up_
endif
select case(heap%dir)
case (psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_'
heap%dir = psb_asort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
call psb_ensure_size(psb_heap_resize,heap%idxs,info)
return
end subroutine psb_z_idx_init_heap
function psb_z_idx_howmany(heap) result(res)
implicit none
class(psb_scomplex_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_z_idx_howmany
subroutine psb_z_idx_insert_heap(key,index,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
complex(@FKIND), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_z_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info == psb_success_) &
& call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_z_idx_insert_heap(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_z_idx_insert_heap
subroutine psb_z_idx_heap_get_first(key,index,heap,info)
implicit none
class(psb_z_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index,info
complex(@FKIND), intent(out) :: key
info = psb_success_
call psi_z_idx_heap_get_first(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_z_idx_heap_get_first
subroutine psb_z_idx_dump_heap(iout,heap,info)
implicit none
class(psb_z_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else if ((heap%last > 0).and.((.not.allocated(heap%idxs)).or.&
& (size(heap%idxs)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
write(iout,*) heap%idxs(1:heap%last)
end if
end subroutine psb_z_idx_dump_heap
subroutine psb_free_z_idx_heap(heap,info)
implicit none
class(psb_z_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_free_z_idx_heap
end module psb_z_sort_mod

1140
base/serial/sort/psb_c_hsort_impl.f90
View File

File diff suppressed because it is too large Load Diff

460
base/serial/sort/psb_c_isort_impl.f90
Unescape Escape View File

@ -0,0 +1,460 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The insertion sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_cisort(x,ix,dir,flag)
use psb_c_sort_mod, psb_protect_name => psb_cisort
use psb_error_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_cisort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_asort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_==psb_sort_ovw_idx_) then
do i=1,n
ix(i) = i
end do
end if
select case(dir_)
case (psb_lsort_up_)
call psi_clisrx_up(n,x,ix)
case (psb_lsort_down_)
call psi_clisrx_dw(n,x,ix)
case (psb_alsort_up_)
call psi_calisrx_up(n,x,ix)
case (psb_alsort_down_)
call psi_calisrx_dw(n,x,ix)
case (psb_asort_up_)
call psi_caisrx_up(n,x,ix)
case (psb_asort_down_)
call psi_caisrx_dw(n,x,ix)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
else
select case(dir_)
case (psb_lsort_up_)
call psi_clisr_up(n,x)
case (psb_lsort_down_)
call psi_clisr_dw(n,x)
case (psb_alsort_up_)
call psi_calisr_up(n,x)
case (psb_alsort_down_)
call psi_calisr_dw(n,x)
case (psb_asort_up_)
call psi_caisr_up(n,x)
case (psb_asort_down_)
call psi_caisr_dw(n,x)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_cisort
subroutine psi_clisrx_up(n,x,ix)
use psb_c_sort_mod, psb_protect_name => psi_clisrx_up
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_clisrx_up
subroutine psi_clisrx_dw(n,x,ix)
use psb_c_sort_mod, psb_protect_name => psi_clisrx_dw
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_clisrx_dw
subroutine psi_clisr_up(n,x)
use psb_c_sort_mod, psb_protect_name => psi_clisr_up
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_clisr_up
subroutine psi_clisr_dw(n,x)
use psb_c_sort_mod, psb_protect_name => psi_clisr_dw
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_clisr_dw
subroutine psi_calisrx_up(n,x,ix)
use psb_c_sort_mod, psb_protect_name => psi_calisrx_up
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_calisrx_up
subroutine psi_calisrx_dw(n,x,ix)
use psb_c_sort_mod, psb_protect_name => psi_calisrx_dw
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_calisrx_dw
subroutine psi_calisr_up(n,x)
use psb_c_sort_mod, psb_protect_name => psi_calisr_up
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_calisr_up
subroutine psi_calisr_dw(n,x)
use psb_c_sort_mod, psb_protect_name => psi_calisr_dw
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_calisr_dw
subroutine psi_caisrx_up(n,x,ix)
use psb_c_sort_mod, psb_protect_name => psi_caisrx_up
use psb_error_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_caisrx_up
subroutine psi_caisrx_dw(n,x,ix)
use psb_c_sort_mod, psb_protect_name => psi_caisrx_dw
use psb_error_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_caisrx_dw
subroutine psi_caisr_up(n,x)
use psb_c_sort_mod, psb_protect_name => psi_caisr_up
use psb_error_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_caisr_up
subroutine psi_caisr_dw(n,x)
use psb_c_sort_mod, psb_protect_name => psi_caisr_dw
use psb_error_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_caisr_dw

782
base/serial/sort/psb_c_msort_impl.f90
Unescape Escape View File

@ -0,0 +1,782 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_cmsort(x,ix,dir,flag)
use psb_c_sort_mod, psb_protect_name => psb_cmsort
use psb_error_mod
use psb_ip_reord_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_cmsort'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_asort_up_
end if
select case(dir_)
case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,&
& psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case(psb_sort_ovw_idx_)
do i=1,n
ix(i) = i
end do
case (psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_c_msort')
goto 9999
endif
select case(idir)
case (psb_lsort_up_)
call in_lmsort_up(n,x,iaux,iret)
case (psb_lsort_down_)
call in_lmsort_dw(n,x,iaux,iret)
case (psb_asort_up_)
call in_amsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call in_amsort_dw(n,x,iaux,iret)
case (psb_alsort_up_)
call in_almsort_up(n,x,iaux,iret)
case (psb_alsort_down_)
call in_almsort_dw(n,x,iaux,iret)
end select
!
! Do the actual reordering, since the inner routines
! only provide linked pointers.
!
if (iret == 0 ) then
if (present(ix)) then
call psb_ip_reord(n,x,indx,iaux)
else
call psb_ip_reord(n,x,iaux)
end if
end if
return
9999 call psb_error_handler(err_act)
return
contains
subroutine in_lmsort_up(n,k,l,iret)
use psb_const_mod
use psi_lcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_lmsort_up
subroutine in_lmsort_dw(n,k,l,iret)
use psb_const_mod
use psi_lcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_lmsort_dw
subroutine in_amsort_up(n,k,l,iret)
use psb_const_mod
use psi_acx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_up
subroutine in_amsort_dw(n,k,l,iret)
use psb_const_mod
use psi_acx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_dw
subroutine in_almsort_up(n,k,l,iret)
use psb_const_mod
use psi_alcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_almsort_up
subroutine in_almsort_dw(n,k,l,iret)
use psb_const_mod
use psi_alcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_almsort_dw
end subroutine psb_cmsort

2505
base/serial/sort/psb_c_qsort_impl.f90
View File

File diff suppressed because it is too large Load Diff

678
base/serial/sort/psb_d_hsort_impl.f90
Unescape Escape View File

@ -0,0 +1,678 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort and quicksort routines are implemented in the
! serial/aux directory
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_dhsort(x,ix,dir,flag)
use psb_d_sort_mod, psb_protect_name => psb_dhsort
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
real(psb_spk_) :: key
integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_hsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case(psb_sort_up_,psb_sort_down_)
! OK
case (psb_asort_up_,psb_asort_down_)
! OK
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
!
! Dirty trick to sort with heaps: if we want
! to sort in place upwards, first we set up a heap so that
! we can easily get the LARGEST element, then we take it out
! and put it in the last entry, and so on.
! So, we invert dir_
!
dir_ = -dir_
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_ == psb_sort_ovw_idx_) then
do i=1, n
ix(i) = i
end do
end if
l = 0
do i=1, n
key = x(i)
index = ix(i)
call psi_d_idx_insert_heap(key,index,l,x,ix,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! '
end if
end do
do i=n, 2, -1
call psi_d_idx_heap_get_first(key,index,l,x,ix,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
ix(i) = index
end do
else if (.not.present(ix)) then
l = 0
do i=1, n
key = x(i)
call psi_d_insert_heap(key,l,x,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i
end if
end do
do i=n, 2, -1
call psi_d_heap_get_first(key,l,x,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
end do
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_dhsort
!
! These are packaged so that they can be used to implement
! a heapsort, should the need arise
!
!
! Programming note:
! In the implementation of the heap_get_first function
! we have code like this
!
! if ( ( heap(2*i) < heap(2*i+1) ) .or.&
! & (2*i == last)) then
! j = 2*i
! else
! j = 2*i + 1
! end if
!
! It looks like the 2*i+1 could overflow the array, but this
! is not true because there is a guard statement
! if (i>last/2) exit
! and because last has just been reduced by 1 when defining the return value,
! therefore 2*i+1 may be greater than the current value of last,
! but cannot be greater than the value of last when the routine was entered
! hence it is safe.
!
!
!
subroutine psi_d_insert_heap(key,last,heap,dir,info)
use psb_d_sort_mod, psb_protect_name => psi_d_insert_heap
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
real(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2
real(psb_dpk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_d_insert_heap
subroutine psi_d_heap_get_first(key,last,heap,dir,info)
use psb_d_sort_mod, psb_protect_name => psi_d_heap_get_first
implicit none
real(psb_dpk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
real(psb_dpk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
info = -1
return
endif
key = heap(1)
heap(1) = heap(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_d_heap_get_first
subroutine psi_d_idx_insert_heap(key,index,last,heap,idxs,dir,info)
use psb_d_sort_mod, psb_protect_name => psi_d_idx_insert_heap
implicit none
!
! Input:
! key: the new value
! index: the new index
! last: pointer to the last occupied element in heap
! heap: the heap
! idxs: the indices
! dir: sorting direction
real(psb_dpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2, itemp
real(psb_dpk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
idxs(i) = index
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_d_idx_insert_heap
subroutine psi_d_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
use psb_d_sort_mod, psb_protect_name => psi_d_idx_heap_get_first
implicit none
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(out) :: key
integer(psb_ipk_) :: i, j,itemp
real(psb_dpk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
index = 0
info = -1
return
endif
key = heap(1)
index = idxs(1)
heap(1) = heap(last)
idxs(1) = idxs(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_d_idx_heap_get_first

340
base/serial/sort/psb_d_isort_impl.f90
Unescape Escape View File

@ -0,0 +1,340 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The insertion sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_disort(x,ix,dir,flag)
use psb_d_sort_mod, psb_protect_name => psb_disort
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_disort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_==psb_sort_ovw_idx_) then
do i=1,n
ix(i) = i
end do
end if
select case(dir_)
case (psb_sort_up_)
call psi_disrx_up(n,x,ix)
case (psb_sort_down_)
call psi_disrx_dw(n,x,ix)
case (psb_asort_up_)
call psi_daisrx_up(n,x,ix)
case (psb_asort_down_)
call psi_daisrx_dw(n,x,ix)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
else
select case(dir_)
case (psb_sort_up_)
call psi_disr_up(n,x)
case (psb_sort_down_)
call psi_disr_dw(n,x)
case (psb_asort_up_)
call psi_daisr_up(n,x)
case (psb_asort_down_)
call psi_daisr_dw(n,x)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_disort
subroutine psi_disrx_up(n,x,ix)
use psb_d_sort_mod, psb_protect_name => psi_disrx_up
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_disrx_up
subroutine psi_disrx_dw(n,x,ix)
use psb_d_sort_mod, psb_protect_name => psi_disrx_dw
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_disrx_dw
subroutine psi_disr_up(n,x)
use psb_d_sort_mod, psb_protect_name => psi_disr_up
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_disr_up
subroutine psi_disr_dw(n,x)
use psb_d_sort_mod, psb_protect_name => psi_disr_dw
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_disr_dw
subroutine psi_daisrx_up(n,x,ix)
use psb_d_sort_mod, psb_protect_name => psi_daisrx_up
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_daisrx_up
subroutine psi_daisrx_dw(n,x,ix)
use psb_d_sort_mod, psb_protect_name => psi_daisrx_dw
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_daisrx_dw
subroutine psi_daisr_up(n,x)
use psb_d_sort_mod, psb_protect_name => psi_daisr_up
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_daisr_up
subroutine psi_daisr_dw(n,x)
use psb_d_sort_mod, psb_protect_name => psi_daisr_dw
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_daisr_dw

566
base/serial/sort/psb_d_msort_impl.f90
Unescape Escape View File

@ -0,0 +1,566 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_dmsort(x,ix,dir,flag)
use psb_d_sort_mod, psb_protect_name => psb_dmsort
use psb_error_mod
use psb_ip_reord_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_dmsort'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case(psb_sort_ovw_idx_)
do i=1,n
ix(i) = i
end do
case (psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_d_msort')
goto 9999
endif
select case(idir)
case (psb_sort_up_)
call in_msort_up(n,x,iaux,iret)
case (psb_sort_down_)
call in_msort_dw(n,x,iaux,iret)
case (psb_asort_up_)
call in_amsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call in_amsort_dw(n,x,iaux,iret)
end select
!
! Do the actual reordering, since the inner routines
! only provide linked pointers.
!
if (iret == 0 ) then
if (present(ix)) then
call psb_ip_reord(n,x,indx,iaux)
else
call psb_ip_reord(n,x,iaux)
end if
end if
return
9999 call psb_error_handler(err_act)
return
contains
subroutine in_msort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_msort_up
subroutine in_msort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_msort_dw
subroutine in_amsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_up
subroutine in_amsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_dw
end subroutine psb_dmsort

1311
base/serial/sort/psb_d_qsort_impl.f90
View File

File diff suppressed because it is too large Load Diff

678
base/serial/sort/psb_i_hsort_impl.f90
Unescape Escape View File

@ -0,0 +1,678 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort and quicksort routines are implemented in the
! serial/aux directory
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_ihsort(x,ix,dir,flag)
use psb_i_sort_mod, psb_protect_name => psb_ihsort
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
real(psb_spk_) :: key
integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_hsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case(psb_sort_up_,psb_sort_down_)
! OK
case (psb_asort_up_,psb_asort_down_)
! OK
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
!
! Dirty trick to sort with heaps: if we want
! to sort in place upwards, first we set up a heap so that
! we can easily get the LARGEST element, then we take it out
! and put it in the last entry, and so on.
! So, we invert dir_
!
dir_ = -dir_
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_ == psb_sort_ovw_idx_) then
do i=1, n
ix(i) = i
end do
end if
l = 0
do i=1, n
key = x(i)
index = ix(i)
call psi_i_idx_insert_heap(key,index,l,x,ix,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! '
end if
end do
do i=n, 2, -1
call psi_i_idx_heap_get_first(key,index,l,x,ix,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
ix(i) = index
end do
else if (.not.present(ix)) then
l = 0
do i=1, n
key = x(i)
call psi_i_insert_heap(key,l,x,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i
end if
end do
do i=n, 2, -1
call psi_i_heap_get_first(key,l,x,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
end do
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_ihsort
!
! These are packaged so that they can be used to implement
! a heapsort, should the need arise
!
!
! Programming note:
! In the implementation of the heap_get_first function
! we have code like this
!
! if ( ( heap(2*i) < heap(2*i+1) ) .or.&
! & (2*i == last)) then
! j = 2*i
! else
! j = 2*i + 1
! end if
!
! It looks like the 2*i+1 could overflow the array, but this
! is not true because there is a guard statement
! if (i>last/2) exit
! and because last has just been reduced by 1 when defining the return value,
! therefore 2*i+1 may be greater than the current value of last,
! but cannot be greater than the value of last when the routine was entered
! hence it is safe.
!
!
!
subroutine psi_i_insert_heap(key,last,heap,dir,info)
use psb_i_sort_mod, psb_protect_name => psi_i_insert_heap
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2
integer(psb_ipk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_insert_heap
subroutine psi_i_heap_get_first(key,last,heap,dir,info)
use psb_i_sort_mod, psb_protect_name => psi_i_heap_get_first
implicit none
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
integer(psb_ipk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
info = -1
return
endif
key = heap(1)
heap(1) = heap(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_heap_get_first
subroutine psi_i_idx_insert_heap(key,index,last,heap,idxs,dir,info)
use psb_i_sort_mod, psb_protect_name => psi_i_idx_insert_heap
implicit none
!
! Input:
! key: the new value
! index: the new index
! last: pointer to the last occupied element in heap
! heap: the heap
! idxs: the indices
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2, itemp
integer(psb_ipk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
idxs(i) = index
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_idx_insert_heap
subroutine psi_i_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
use psb_i_sort_mod, psb_protect_name => psi_i_idx_heap_get_first
implicit none
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_) :: i, j,itemp
integer(psb_ipk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
index = 0
info = -1
return
endif
key = heap(1)
index = idxs(1)
heap(1) = heap(last)
idxs(1) = idxs(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_idx_heap_get_first

340
base/serial/sort/psb_i_isort_impl.f90
Unescape Escape View File

@ -0,0 +1,340 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The insertion sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_iisort(x,ix,dir,flag)
use psb_i_sort_mod, psb_protect_name => psb_iisort
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_iisort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_==psb_sort_ovw_idx_) then
do i=1,n
ix(i) = i
end do
end if
select case(dir_)
case (psb_sort_up_)
call psi_iisrx_up(n,x,ix)
case (psb_sort_down_)
call psi_iisrx_dw(n,x,ix)
case (psb_asort_up_)
call psi_iaisrx_up(n,x,ix)
case (psb_asort_down_)
call psi_iaisrx_dw(n,x,ix)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
else
select case(dir_)
case (psb_sort_up_)
call psi_iisr_up(n,x)
case (psb_sort_down_)
call psi_iisr_dw(n,x)
case (psb_asort_up_)
call psi_iaisr_up(n,x)
case (psb_asort_down_)
call psi_iaisr_dw(n,x)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_iisort
subroutine psi_iisrx_up(n,x,ix)
use psb_i_sort_mod, psb_protect_name => psi_iisrx_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iisrx_up
subroutine psi_iisrx_dw(n,x,ix)
use psb_i_sort_mod, psb_protect_name => psi_iisrx_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iisrx_dw
subroutine psi_iisr_up(n,x)
use psb_i_sort_mod, psb_protect_name => psi_iisr_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iisr_up
subroutine psi_iisr_dw(n,x)
use psb_i_sort_mod, psb_protect_name => psi_iisr_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iisr_dw
subroutine psi_iaisrx_up(n,x,ix)
use psb_i_sort_mod, psb_protect_name => psi_iaisrx_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iaisrx_up
subroutine psi_iaisrx_dw(n,x,ix)
use psb_i_sort_mod, psb_protect_name => psi_iaisrx_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iaisrx_dw
subroutine psi_iaisr_up(n,x)
use psb_i_sort_mod, psb_protect_name => psi_iaisr_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iaisr_up
subroutine psi_iaisr_dw(n,x)
use psb_i_sort_mod, psb_protect_name => psi_iaisr_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iaisr_dw

757
base/serial/sort/psb_i_msort_impl.f90
Unescape Escape View File

@ -0,0 +1,757 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
logical function psb_isaperm(n,eip)
use psb_i_sort_mod, psb_protect_name => psb_isaperm
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: eip(n)
integer(psb_ipk_), allocatable :: ip(:)
integer(psb_ipk_) :: i,j,m, info
psb_isaperm = .true.
if (n <= 0) return
allocate(ip(n), stat=info)
if (info /= psb_success_) return
!
! sanity check first
!
do i=1, n
ip(i) = eip(i)
if ((ip(i) < 1).or.(ip(i) > n)) then
write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n
psb_isaperm = .false.
return
endif
enddo
!
! now work through the cycles, by marking each successive item as negative.
! no cycle should intersect with any other, hence the >= 1 check.
!
do m = 1, n
i = ip(m)
if (i < 0) then
ip(m) = -i
else if (i /= m) then
j = ip(i)
ip(i) = -j
i = j
do while ((j >= 1).and.(j /= m))
j = ip(i)
ip(i) = -j
i = j
enddo
ip(m) = abs(ip(m))
if (j /= m) then
psb_isaperm = .false.
goto 9999
endif
end if
enddo
9999 continue
return
end function psb_isaperm
function psb_iblsrch(key,n,v) result(ipos)
use psb_i_sort_mod, psb_protect_name => psb_iblsrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m
if (n < 5) then
! don't bother with binary search for very
! small vectors
ipos = 0
do
if (ipos == n) return
if (key < v(ipos+1)) return
ipos = ipos + 1
end do
else
lb = 1
ub = n
ipos = -1
do while (lb <= ub)
m = (lb+ub)/2
if (key==v(m)) then
ipos = m
return
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (v(ub) > key) then
!!$ write(0,*) 'Check: ',ub,v(ub),key
ub = ub - 1
end if
ipos = ub
endif
return
end function psb_iblsrch
function psb_ibsrch(key,n,v) result(ipos)
use psb_i_sort_mod, psb_protect_name => psb_ibsrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m
lb = 1
ub = n
ipos = -1
do while (lb.le.ub)
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
lb = ub + 1
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end function psb_ibsrch
function psb_issrch(key,n,v) result(ipos)
use psb_i_sort_mod, psb_protect_name => psb_issrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: i
ipos = -1
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end function psb_issrch
subroutine psb_imsort_u(x,nout,dir)
use psb_i_sort_mod, psb_protect_name => psb_imsort_u
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_ipk_) :: dir_, n, err_act, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
call psb_imsort(x,dir_)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_imsort_u
subroutine psb_imsort(x,ix,dir,flag)
use psb_i_sort_mod, psb_protect_name => psb_imsort
use psb_error_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_imsort'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case(psb_sort_ovw_idx_)
do i=1,n
ix(i) = i
end do
case (psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_i_msort')
goto 9999
endif
select case(idir)
case (psb_sort_up_)
call in_msort_up(n,x,iaux,iret)
case (psb_sort_down_)
call in_msort_dw(n,x,iaux,iret)
case (psb_asort_up_)
call in_amsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call in_amsort_dw(n,x,iaux,iret)
end select
!
! Do the actual reordering, since the inner routines
! only provide linked pointers.
!
if (iret == 0 ) then
if (present(ix)) then
call psb_ip_reord(n,x,indx,iaux)
else
call psb_ip_reord(n,x,iaux)
end if
end if
return
9999 call psb_error_handler(err_act)
return
contains
subroutine in_msort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_msort_up
subroutine in_msort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_msort_dw
subroutine in_amsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_up
subroutine in_amsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_dw
end subroutine psb_imsort

1311
base/serial/sort/psb_i_qsort_impl.f90
View File

File diff suppressed because it is too large Load Diff

678
base/serial/sort/psb_s_hsort_impl.f90
Unescape Escape View File

@ -0,0 +1,678 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort and quicksort routines are implemented in the
! serial/aux directory
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_shsort(x,ix,dir,flag)
use psb_s_sort_mod, psb_protect_name => psb_shsort
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
real(psb_spk_) :: key
integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_hsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case(psb_sort_up_,psb_sort_down_)
! OK
case (psb_asort_up_,psb_asort_down_)
! OK
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
!
! Dirty trick to sort with heaps: if we want
! to sort in place upwards, first we set up a heap so that
! we can easily get the LARGEST element, then we take it out
! and put it in the last entry, and so on.
! So, we invert dir_
!
dir_ = -dir_
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_ == psb_sort_ovw_idx_) then
do i=1, n
ix(i) = i
end do
end if
l = 0
do i=1, n
key = x(i)
index = ix(i)
call psi_s_idx_insert_heap(key,index,l,x,ix,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! '
end if
end do
do i=n, 2, -1
call psi_s_idx_heap_get_first(key,index,l,x,ix,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
ix(i) = index
end do
else if (.not.present(ix)) then
l = 0
do i=1, n
key = x(i)
call psi_s_insert_heap(key,l,x,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i
end if
end do
do i=n, 2, -1
call psi_s_heap_get_first(key,l,x,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
end do
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_shsort
!
! These are packaged so that they can be used to implement
! a heapsort, should the need arise
!
!
! Programming note:
! In the implementation of the heap_get_first function
! we have code like this
!
! if ( ( heap(2*i) < heap(2*i+1) ) .or.&
! & (2*i == last)) then
! j = 2*i
! else
! j = 2*i + 1
! end if
!
! It looks like the 2*i+1 could overflow the array, but this
! is not true because there is a guard statement
! if (i>last/2) exit
! and because last has just been reduced by 1 when defining the return value,
! therefore 2*i+1 may be greater than the current value of last,
! but cannot be greater than the value of last when the routine was entered
! hence it is safe.
!
!
!
subroutine psi_s_insert_heap(key,last,heap,dir,info)
use psb_s_sort_mod, psb_protect_name => psi_s_insert_heap
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
real(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2
real(psb_spk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_s_insert_heap
subroutine psi_s_heap_get_first(key,last,heap,dir,info)
use psb_s_sort_mod, psb_protect_name => psi_s_heap_get_first
implicit none
real(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
real(psb_spk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
info = -1
return
endif
key = heap(1)
heap(1) = heap(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_s_heap_get_first
subroutine psi_s_idx_insert_heap(key,index,last,heap,idxs,dir,info)
use psb_s_sort_mod, psb_protect_name => psi_s_idx_insert_heap
implicit none
!
! Input:
! key: the new value
! index: the new index
! last: pointer to the last occupied element in heap
! heap: the heap
! idxs: the indices
! dir: sorting direction
real(psb_spk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2, itemp
real(psb_spk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
idxs(i) = index
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_s_idx_insert_heap
subroutine psi_s_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
use psb_s_sort_mod, psb_protect_name => psi_s_idx_heap_get_first
implicit none
real(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(out) :: key
integer(psb_ipk_) :: i, j,itemp
real(psb_spk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
index = 0
info = -1
return
endif
key = heap(1)
index = idxs(1)
heap(1) = heap(last)
idxs(1) = idxs(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_s_idx_heap_get_first

340
base/serial/sort/psb_s_isort_impl.f90
Unescape Escape View File

@ -0,0 +1,340 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The insertion sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_sisort(x,ix,dir,flag)
use psb_s_sort_mod, psb_protect_name => psb_sisort
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_sisort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_==psb_sort_ovw_idx_) then
do i=1,n
ix(i) = i
end do
end if
select case(dir_)
case (psb_sort_up_)
call psi_sisrx_up(n,x,ix)
case (psb_sort_down_)
call psi_sisrx_dw(n,x,ix)
case (psb_asort_up_)
call psi_saisrx_up(n,x,ix)
case (psb_asort_down_)
call psi_saisrx_dw(n,x,ix)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
else
select case(dir_)
case (psb_sort_up_)
call psi_sisr_up(n,x)
case (psb_sort_down_)
call psi_sisr_dw(n,x)
case (psb_asort_up_)
call psi_saisr_up(n,x)
case (psb_asort_down_)
call psi_saisr_dw(n,x)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_sisort
subroutine psi_sisrx_up(n,x,ix)
use psb_s_sort_mod, psb_protect_name => psi_sisrx_up
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_sisrx_up
subroutine psi_sisrx_dw(n,x,ix)
use psb_s_sort_mod, psb_protect_name => psi_sisrx_dw
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_sisrx_dw
subroutine psi_sisr_up(n,x)
use psb_s_sort_mod, psb_protect_name => psi_sisr_up
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_sisr_up
subroutine psi_sisr_dw(n,x)
use psb_s_sort_mod, psb_protect_name => psi_sisr_dw
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_sisr_dw
subroutine psi_saisrx_up(n,x,ix)
use psb_s_sort_mod, psb_protect_name => psi_saisrx_up
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_saisrx_up
subroutine psi_saisrx_dw(n,x,ix)
use psb_s_sort_mod, psb_protect_name => psi_saisrx_dw
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_saisrx_dw
subroutine psi_saisr_up(n,x)
use psb_s_sort_mod, psb_protect_name => psi_saisr_up
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_saisr_up
subroutine psi_saisr_dw(n,x)
use psb_s_sort_mod, psb_protect_name => psi_saisr_dw
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_saisr_dw

566
base/serial/sort/psb_s_msort_impl.f90
Unescape Escape View File

@ -0,0 +1,566 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_smsort(x,ix,dir,flag)
use psb_s_sort_mod, psb_protect_name => psb_smsort
use psb_error_mod
use psb_ip_reord_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_smsort'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case(psb_sort_ovw_idx_)
do i=1,n
ix(i) = i
end do
case (psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_s_msort')
goto 9999
endif
select case(idir)
case (psb_sort_up_)
call in_msort_up(n,x,iaux,iret)
case (psb_sort_down_)
call in_msort_dw(n,x,iaux,iret)
case (psb_asort_up_)
call in_amsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call in_amsort_dw(n,x,iaux,iret)
end select
!
! Do the actual reordering, since the inner routines
! only provide linked pointers.
!
if (iret == 0 ) then
if (present(ix)) then
call psb_ip_reord(n,x,indx,iaux)
else
call psb_ip_reord(n,x,iaux)
end if
end if
return
9999 call psb_error_handler(err_act)
return
contains
subroutine in_msort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_msort_up
subroutine in_msort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_msort_dw
subroutine in_amsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_up
subroutine in_amsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_dw
end subroutine psb_smsort

1311
base/serial/sort/psb_s_qsort_impl.f90
View File

File diff suppressed because it is too large Load Diff

1140
base/serial/sort/psb_z_hsort_impl.f90
View File

File diff suppressed because it is too large Load Diff

460
base/serial/sort/psb_z_isort_impl.f90
Unescape Escape View File

@ -0,0 +1,460 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The insertion sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_zisort(x,ix,dir,flag)
use psb_z_sort_mod, psb_protect_name => psb_zisort
use psb_error_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_zisort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_asort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_==psb_sort_ovw_idx_) then
do i=1,n
ix(i) = i
end do
end if
select case(dir_)
case (psb_lsort_up_)
call psi_zlisrx_up(n,x,ix)
case (psb_lsort_down_)
call psi_zlisrx_dw(n,x,ix)
case (psb_alsort_up_)
call psi_zalisrx_up(n,x,ix)
case (psb_alsort_down_)
call psi_zalisrx_dw(n,x,ix)
case (psb_asort_up_)
call psi_zaisrx_up(n,x,ix)
case (psb_asort_down_)
call psi_zaisrx_dw(n,x,ix)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
else
select case(dir_)
case (psb_lsort_up_)
call psi_zlisr_up(n,x)
case (psb_lsort_down_)
call psi_zlisr_dw(n,x)
case (psb_alsort_up_)
call psi_zalisr_up(n,x)
case (psb_alsort_down_)
call psi_zalisr_dw(n,x)
case (psb_asort_up_)
call psi_zaisr_up(n,x)
case (psb_asort_down_)
call psi_zaisr_dw(n,x)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_zisort
subroutine psi_zlisrx_up(n,x,ix)
use psb_z_sort_mod, psb_protect_name => psi_zlisrx_up
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_zlisrx_up
subroutine psi_zlisrx_dw(n,x,ix)
use psb_z_sort_mod, psb_protect_name => psi_zlisrx_dw
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_zlisrx_dw
subroutine psi_zlisr_up(n,x)
use psb_z_sort_mod, psb_protect_name => psi_zlisr_up
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_zlisr_up
subroutine psi_zlisr_dw(n,x)
use psb_z_sort_mod, psb_protect_name => psi_zlisr_dw
use psb_error_mod
use psi_lcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_zlisr_dw
subroutine psi_zalisrx_up(n,x,ix)
use psb_z_sort_mod, psb_protect_name => psi_zalisrx_up
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_zalisrx_up
subroutine psi_zalisrx_dw(n,x,ix)
use psb_z_sort_mod, psb_protect_name => psi_zalisrx_dw
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_zalisrx_dw
subroutine psi_zalisr_up(n,x)
use psb_z_sort_mod, psb_protect_name => psi_zalisr_up
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_zalisr_up
subroutine psi_zalisr_dw(n,x)
use psb_z_sort_mod, psb_protect_name => psi_zalisr_dw
use psb_error_mod
use psi_alcx_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_zalisr_dw
subroutine psi_zaisrx_up(n,x,ix)
use psb_z_sort_mod, psb_protect_name => psi_zaisrx_up
use psb_error_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_zaisrx_up
subroutine psi_zaisrx_dw(n,x,ix)
use psb_z_sort_mod, psb_protect_name => psi_zaisrx_dw
use psb_error_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_zaisrx_dw
subroutine psi_zaisr_up(n,x)
use psb_z_sort_mod, psb_protect_name => psi_zaisr_up
use psb_error_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_zaisr_up
subroutine psi_zaisr_dw(n,x)
use psb_z_sort_mod, psb_protect_name => psi_zaisr_dw
use psb_error_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_zaisr_dw

782
base/serial/sort/psb_z_msort_impl.f90
Unescape Escape View File

@ -0,0 +1,782 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! The merge-sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_zmsort(x,ix,dir,flag)
use psb_z_sort_mod, psb_protect_name => psb_zmsort
use psb_error_mod
use psb_ip_reord_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_zmsort'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_asort_up_
end if
select case(dir_)
case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,&
& psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case(psb_sort_ovw_idx_)
do i=1,n
ix(i) = i
end do
case (psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_z_msort')
goto 9999
endif
select case(idir)
case (psb_lsort_up_)
call in_lmsort_up(n,x,iaux,iret)
case (psb_lsort_down_)
call in_lmsort_dw(n,x,iaux,iret)
case (psb_asort_up_)
call in_amsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call in_amsort_dw(n,x,iaux,iret)
case (psb_alsort_up_)
call in_almsort_up(n,x,iaux,iret)
case (psb_alsort_down_)
call in_almsort_dw(n,x,iaux,iret)
end select
!
! Do the actual reordering, since the inner routines
! only provide linked pointers.
!
if (iret == 0 ) then
if (present(ix)) then
call psb_ip_reord(n,x,indx,iaux)
else
call psb_ip_reord(n,x,iaux)
end if
end if
return
9999 call psb_error_handler(err_act)
return
contains
subroutine in_lmsort_up(n,k,l,iret)
use psb_const_mod
use psi_lcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_lmsort_up
subroutine in_lmsort_dw(n,k,l,iret)
use psb_const_mod
use psi_lcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_lmsort_dw
subroutine in_amsort_up(n,k,l,iret)
use psb_const_mod
use psi_acx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_up
subroutine in_amsort_dw(n,k,l,iret)
use psb_const_mod
use psi_acx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_amsort_dw
subroutine in_almsort_up(n,k,l,iret)
use psb_const_mod
use psi_alcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_almsort_up
subroutine in_almsort_dw(n,k,l,iret)
use psb_const_mod
use psi_alcx_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine in_almsort_dw
end subroutine psb_zmsort

2505
base/serial/sort/psb_z_qsort_impl.f90
View File

File diff suppressed because it is too large Load Diff

0
base/serial/aux/psi_acx_mod.f90 → base/serial/sort/psi_acx_mod.f90
Unescape Escape View File

0
base/serial/aux/psi_alcx_mod.f90 → base/serial/sort/psi_alcx_mod.f90
Unescape Escape View File

0
base/serial/aux/psi_lcx_mod.f90 → base/serial/sort/psi_lcx_mod.f90
Unescape Escape View File

Write Preview
Loading…
Cancel
Save