diff --git a/base/modules/Makefile b/base/modules/Makefile index 20073d7e..7b448939 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -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_glist_map_mod.o psb_hash_map_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_c_tools_mod.o psb_z_tools_mod.o psb_tools_mod.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_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_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_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 \ @@ -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 +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_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 diff --git a/base/modules/psb_c_sort_mod.f90 b/base/modules/psb_c_sort_mod.f90 new file mode 100644 index 00000000..35420672 --- /dev/null +++ b/base/modules/psb_c_sort_mod.f90 @@ -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) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 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) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 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) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 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) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 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) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) psb_chsort + 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, 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_lsort_up_,psb_lsort_down_,psb_alsort_up_,psb_alsort_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_c_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_c_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_c_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_c_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_chsort + + + +! +! 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_c_insert_heap(key,last,heap,dir,info) + use psb_c_sort_mod, psb_protect_name => psi_c_insert_heap + 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 + integer(psb_ipk_), intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2 + complex(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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap) + + case (psb_asort_down_) + call fix_adw(last,heap) + + case (psb_alsort_up_) + call fix_alup(last,heap) + + case (psb_alsort_down_) + call fix_aldw(last,heap) + + case (psb_lsort_up_) + call fix_lup(last,heap) + + case (psb_lsort_down_) + call fix_ldw(last,heap) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return + +contains + + subroutine fix_aup(last,heap) + use psi_acx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_spk_) :: temp + + i=last + 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 + end subroutine fix_aup + + subroutine fix_adw(last,heap) + use psi_acx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_spk_) :: temp + + i=last + 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 + end subroutine fix_adw + + + subroutine fix_lup(last,heap) + use psi_lcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_spk_) :: temp + + i=last + 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 + end subroutine fix_lup + + subroutine fix_ldw(last,heap) + use psi_lcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_spk_) :: temp + + i=last + 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 + end subroutine fix_ldw + + subroutine fix_alup(last,heap) + use psi_alcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_spk_) :: temp + + i=last + 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 + end subroutine fix_alup + + subroutine fix_aldw(last,heap) + use psi_alcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_spk_) :: temp + + i=last + 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 + end subroutine fix_aldw + +end subroutine psi_c_insert_heap + +subroutine psi_c_heap_get_first(key,last,heap,dir,info) + use psb_c_sort_mod, psb_protect_name => psi_c_insert_heap + 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(inout) :: 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 + + integer(psb_ipk_) :: i + + 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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap) + + case (psb_asort_down_) + call fix_adw(last,heap) + + case (psb_alsort_up_) + call fix_alup(last,heap) + + case (psb_alsort_down_) + call fix_aldw(last,heap) + + case (psb_lsort_up_) + call fix_lup(last,heap) + + case (psb_lsort_down_) + call fix_ldw(last,heap) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +contains + + subroutine fix_aup(last,heap) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_spk_) :: temp + + 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 + + end subroutine fix_aup + + + subroutine fix_adw(last,heap) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_spk_) :: temp + + 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 + + end subroutine fix_adw + + subroutine fix_lup(last,heap) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_spk_) :: temp + + 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 + + end subroutine fix_lup + + subroutine fix_ldw(last,heap) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_spk_) :: temp + + 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 + + end subroutine fix_ldw + + subroutine fix_alup(last,heap) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_spk_) :: temp + + 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 + + end subroutine fix_alup + + subroutine fix_aldw(last,heap) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_spk_) :: temp + + 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 + + end subroutine fix_aldw + +end subroutine psi_c_heap_get_first + +subroutine psi_c_idx_insert_heap(key,index,last,heap,idxs,dir,info) + use psb_c_sort_mod, psb_protect_name => psi_c_idx_insert_idx_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 + + 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(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2, itemp + complex(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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap,idxs) + + case (psb_asort_down_) + call fix_adw(last,heap,idxs) + + case (psb_alsort_up_) + call fix_alup(last,heap,idxs) + + case (psb_alsort_down_) + call fix_aldw(last,heap,idxs) + + case (psb_lsort_up_) + call fix_lup(last,heap,idxs) + + case (psb_lsort_down_) + call fix_ldw(last,heap,idxs) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return + +contains + + subroutine fix_aup(last,heap,idxs) + use psi_acx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_spk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_aup + + subroutine fix_adw(last,heap,idxs) + use psi_acx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_spk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_adw + + + subroutine fix_lup(last,heap,idxs) + use psi_lcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_spk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_lup + + subroutine fix_ldw(last,heap,idxs) + use psi_lcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_spk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_ldw + + subroutine fix_alup(last,heap,idxs) + use psi_alcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_spk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_alup + + subroutine fix_aldw(last,heap,idxs) + use psi_alcx_mod + implicit none + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_spk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_aldw + +end subroutine psi_c_idx_insert_heap + + + +subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_c_sort_mod, psb_protect_name => psi_c_insert_heap + 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(inout) :: key + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i + + 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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap) + + case (psb_asort_down_) + call fix_adw(last,heap) + + case (psb_alsort_up_) + call fix_alup(last,heap) + + case (psb_alsort_down_) + call fix_aldw(last,heap) + + case (psb_lsort_up_) + call fix_lup(last,heap) + + case (psb_lsort_down_) + call fix_ldw(last,heap) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +contains + + subroutine fix_aup(last,heap,idxs) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_spk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_aup + + + subroutine fix_adw(last,heap,idxs) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_spk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_adw + + subroutine fix_lup(last,heap,idxs) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_spk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_lup + + subroutine fix_ldw(last,heap,idxs) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_spk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_ldw + + subroutine fix_alup(last,heap,idxs) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_spk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_alup + + subroutine fix_aldw(last,heap,idxs) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_spk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_aldw + +end subroutine psi_c_heap_get_first + + + diff --git a/base/serial/sort/psb_c_isort_impl.f90 b/base/serial/sort/psb_c_isort_impl.f90 new file mode 100644 index 00000000..16109736 --- /dev/null +++ b/base/serial/sort/psb_c_isort_impl.f90 @@ -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 + diff --git a/base/serial/sort/psb_c_msort_impl.f90 b/base/serial/sort/psb_c_msort_impl.f90 new file mode 100644 index 00000000..f339739f --- /dev/null +++ b/base/serial/sort/psb_c_msort_impl.f90 @@ -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 diff --git a/base/serial/sort/psb_c_qsort_impl.f90 b/base/serial/sort/psb_c_qsort_impl.f90 new file mode 100644 index 00000000..e6a2138a --- /dev/null +++ b/base/serial/sort/psb_c_qsort_impl.f90 @@ -0,0 +1,2505 @@ +!!$ +!!$ 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 quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_cqsort(x,ix,dir,flag) + use psb_c_sort_mod, psb_protect_name => psb_cqsort + 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 + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_cqsort' + 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_clqsrx_up(n,x,ix) + case (psb_lsort_down_) + call psi_clqsrx_dw(n,x,ix) + case (psb_alsort_up_) + call psi_calqsrx_up(n,x,ix) + case (psb_alsort_down_) + call psi_calqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_caqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_caqsrx_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_clqsr_up(n,x) + case (psb_lsort_down_) + call psi_clqsr_dw(n,x) + case (psb_alsort_up_) + call psi_calqsr_up(n,x) + case (psb_alsort_down_) + call psi_calqsr_dw(n,x) + case (psb_asort_up_) + call psi_caqsr_up(n,x) + case (psb_asort_down_) + call psi_caqsr_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_cqsort + + + +subroutine psi_cqsrx_up(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_cqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_cisrx_up(n,x,indx) + endif +end subroutine psi_cqsrx_up + +subroutine psi_cqsrx_dw(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_cqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_cisrx_dw(n,x,indx) + endif + +end subroutine psi_cqsrx_dw + +subroutine psi_cqsr_up(n,x) + use psb_c_sort_mod, psb_protect_name => psi_cqsr_up + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_cisr_up(n,x) + endif + +end subroutine psi_cqsr_up + +subroutine psi_cqsr_dw(n,x) + use psb_c_sort_mod, psb_protect_name => psi_cqsr_dw + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_cqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_cisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_cisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_cisr_dw(n,x) + endif + +end subroutine psi_cqsr_dw + +@NOTCE@ +subroutine psi_clqsrx_up(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_clqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_clisrx_up(n,x,indx) + endif + +end subroutine psi_clqsrx_up + +subroutine psi_clqsrx_dw(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_clqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_clisrx_dw(n,x,indx) + endif +end subroutine psi_clqsrx_dw + +subroutine psi_clqsr_up(n,x) + use psb_c_sort_mod, psb_protect_name => psi_clqsr_up + use psb_error_mod + use psi_lcx_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_clisr_up(n,x) + endif + +end subroutine psi_clqsr_up + +subroutine psi_clqsr_dw(n,x) + use psb_c_sort_mod, psb_protect_name => psi_clqsr_dw + use psb_error_mod + use psi_lcx_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_cqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_clisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_clisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_clisr_dw(n,x) + endif + +end subroutine psi_clqsr_dw + +subroutine psi_calqsrx_up(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_calqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_calisrx_up(n,x,indx) + endif +end subroutine psi_calqsrx_up + +subroutine psi_calqsrx_dw(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_calqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_calisrx_dw(n,x,indx) + endif +end subroutine psi_calqsrx_dw + +subroutine psi_calqsr_up(n,x) + use psb_c_sort_mod, psb_protect_name => psi_calqsr_up + use psb_error_mod + use psi_alcx_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_calisr_up(n,x) + endif +end subroutine psi_calqsr_up + +subroutine psi_calqsr_dw(n,x) + use psb_c_sort_mod, psb_protect_name => psi_calqsr_dw + use psb_error_mod + use psi_alcx_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_cqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_calisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_calisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_calisr_dw(n,x) + endif +end subroutine psi_calqsr_dw + +subroutine psi_caqsrx_up(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_caqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_caqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_caisrx_up(n,x,indx) + endif + + +end subroutine psi_caqsrx_up + +subroutine psi_caqsrx_dw(n,x,ix) + use psb_c_sort_mod, psb_protect_name => psi_caqsrx_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 + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_caqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_caisrx_dw(n,x,indx) + endif + +end subroutine psi_caqsrx_dw + +subroutine psi_caqsr_up(n,x) + use psb_c_sort_mod, psb_protect_name => psi_caqsr_up + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_cqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_caisr_up(n,x) + endif + +end subroutine psi_caqsr_up + +subroutine psi_caqsr_dw(n,x) + use psb_c_sort_mod, psb_protect_name => psi_caqsr_dw + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_cqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_caisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_caisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_caisr_dw(n,x) + endif + +end subroutine psi_caqsr_dw + + diff --git a/base/serial/sort/psb_d_hsort_impl.f90 b/base/serial/sort/psb_d_hsort_impl.f90 new file mode 100644 index 00000000..d8d0ac0e --- /dev/null +++ b/base/serial/sort/psb_d_hsort_impl.f90 @@ -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 + + + + diff --git a/base/serial/sort/psb_d_isort_impl.f90 b/base/serial/sort/psb_d_isort_impl.f90 new file mode 100644 index 00000000..86593c27 --- /dev/null +++ b/base/serial/sort/psb_d_isort_impl.f90 @@ -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 + diff --git a/base/serial/sort/psb_d_msort_impl.f90 b/base/serial/sort/psb_d_msort_impl.f90 new file mode 100644 index 00000000..9cb40ab2 --- /dev/null +++ b/base/serial/sort/psb_d_msort_impl.f90 @@ -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 + + + + + + + diff --git a/base/serial/sort/psb_d_qsort_impl.f90 b/base/serial/sort/psb_d_qsort_impl.f90 new file mode 100644 index 00000000..d6291ebc --- /dev/null +++ b/base/serial/sort/psb_d_qsort_impl.f90 @@ -0,0 +1,1311 @@ +!!$ +!!$ 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 quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_dqsort(x,ix,dir,flag) + use psb_d_sort_mod, psb_protect_name => psb_dqsort + 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 + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_dqsort' + 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_dqsrx_up(n,x,ix) + case (psb_sort_down_) + call psi_dqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_daqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_daqsrx_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_dqsr_up(n,x) + case (psb_sort_down_) + call psi_dqsr_dw(n,x) + case (psb_asort_up_) + call psi_daqsr_up(n,x) + case (psb_asort_down_) + call psi_daqsr_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_dqsort + + + +subroutine psi_dqsrx_up(n,x,ix) + use psb_d_sort_mod, psb_protect_name => psi_dqsrx_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 + ! .. Local Scalars .. + real(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_dqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_disrx_up(n,x,indx) + endif +end subroutine psi_dqsrx_up + +subroutine psi_dqsrx_dw(n,x,ix) + use psb_d_sort_mod, psb_protect_name => psi_dqsrx_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 + ! .. Local Scalars .. + real(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_dqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_disrx_dw(n,x,indx) + endif + +end subroutine psi_dqsrx_dw + +subroutine psi_dqsr_up(n,x) + use psb_d_sort_mod, psb_protect_name => psi_dqsr_up + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + real(psb_dpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_dqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_disr_up(n,x) + endif + +end subroutine psi_dqsr_up + +subroutine psi_dqsr_dw(n,x) + use psb_d_sort_mod, psb_protect_name => psi_dqsr_dw + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + real(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_dqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_disr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_disr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_disr_dw(n,x) + endif + +end subroutine psi_dqsr_dw + +subroutine psi_daqsrx_up(n,x,ix) + use psb_d_sort_mod, psb_protect_name => psi_daqsrx_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 + ! .. Local Scalars .. + real(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_daqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_daisrx_up(n,x,indx) + endif + + +end subroutine psi_daqsrx_up + +subroutine psi_daqsrx_dw(n,x,ix) + use psb_d_sort_mod, psb_protect_name => psi_daqsrx_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 + ! .. Local Scalars .. + real(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_daqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_daisrx_dw(n,x,indx) + endif + +end subroutine psi_daqsrx_dw + +subroutine psi_daqsr_up(n,x) + use psb_d_sort_mod, psb_protect_name => psi_daqsr_up + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + real(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_dqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_daisr_up(n,x) + endif + +end subroutine psi_daqsr_up + +subroutine psi_daqsr_dw(n,x) + use psb_d_sort_mod, psb_protect_name => psi_daqsr_dw + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + real(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_dqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_daisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_daisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_daisr_dw(n,x) + endif + +end subroutine psi_daqsr_dw + + diff --git a/base/serial/sort/psb_i_hsort_impl.f90 b/base/serial/sort/psb_i_hsort_impl.f90 new file mode 100644 index 00000000..85dc0b10 --- /dev/null +++ b/base/serial/sort/psb_i_hsort_impl.f90 @@ -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 + + + + diff --git a/base/serial/sort/psb_i_isort_impl.f90 b/base/serial/sort/psb_i_isort_impl.f90 new file mode 100644 index 00000000..c122be02 --- /dev/null +++ b/base/serial/sort/psb_i_isort_impl.f90 @@ -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 + diff --git a/base/serial/sort/psb_i_msort_impl.f90 b/base/serial/sort/psb_i_msort_impl.f90 new file mode 100644 index 00000000..59cdf0f8 --- /dev/null +++ b/base/serial/sort/psb_i_msort_impl.f90 @@ -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 + + + + + + + diff --git a/base/serial/sort/psb_i_qsort_impl.f90 b/base/serial/sort/psb_i_qsort_impl.f90 new file mode 100644 index 00000000..2eeb0f8c --- /dev/null +++ b/base/serial/sort/psb_i_qsort_impl.f90 @@ -0,0 +1,1311 @@ +!!$ +!!$ 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 quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_iqsort(x,ix,dir,flag) + use psb_i_sort_mod, psb_protect_name => psb_iqsort + 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 + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_iqsort' + 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_iqsrx_up(n,x,ix) + case (psb_sort_down_) + call psi_iqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_iaqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_iaqsrx_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_iqsr_up(n,x) + case (psb_sort_down_) + call psi_iqsr_dw(n,x) + case (psb_asort_up_) + call psi_iaqsr_up(n,x) + case (psb_asort_down_) + call psi_iaqsr_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_iqsort + + + +subroutine psi_iqsrx_up(n,x,ix) + use psb_i_sort_mod, psb_protect_name => psi_iqsrx_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 + ! .. Local Scalars .. + integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_iqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_iisrx_up(n,x,indx) + endif +end subroutine psi_iqsrx_up + +subroutine psi_iqsrx_dw(n,x,ix) + use psb_i_sort_mod, psb_protect_name => psi_iqsrx_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 + ! .. Local Scalars .. + integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_iqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_iisrx_dw(n,x,indx) + endif + +end subroutine psi_iqsrx_dw + +subroutine psi_iqsr_up(n,x) + use psb_i_sort_mod, psb_protect_name => psi_iqsr_up + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_ipk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_iqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_iisr_up(n,x) + endif + +end subroutine psi_iqsr_up + +subroutine psi_iqsr_dw(n,x) + use psb_i_sort_mod, psb_protect_name => psi_iqsr_dw + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_iqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_iisr_dw(n,x) + endif + +end subroutine psi_iqsr_dw + +subroutine psi_iaqsrx_up(n,x,ix) + use psb_i_sort_mod, psb_protect_name => psi_iaqsrx_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 + ! .. Local Scalars .. + integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_iaqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_iaisrx_up(n,x,indx) + endif + + +end subroutine psi_iaqsrx_up + +subroutine psi_iaqsrx_dw(n,x,ix) + use psb_i_sort_mod, psb_protect_name => psi_iaqsrx_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 + ! .. Local Scalars .. + integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_iaqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_iaisrx_dw(n,x,indx) + endif + +end subroutine psi_iaqsrx_dw + +subroutine psi_iaqsr_up(n,x) + use psb_i_sort_mod, psb_protect_name => psi_iaqsr_up + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_iqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_iaisr_up(n,x) + endif + +end subroutine psi_iaqsr_up + +subroutine psi_iaqsr_dw(n,x) + use psb_i_sort_mod, psb_protect_name => psi_iaqsr_dw + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_iqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_iaisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_iaisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_iaisr_dw(n,x) + endif + +end subroutine psi_iaqsr_dw + + diff --git a/base/serial/sort/psb_s_hsort_impl.f90 b/base/serial/sort/psb_s_hsort_impl.f90 new file mode 100644 index 00000000..5f8f5c49 --- /dev/null +++ b/base/serial/sort/psb_s_hsort_impl.f90 @@ -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 + + + + diff --git a/base/serial/sort/psb_s_isort_impl.f90 b/base/serial/sort/psb_s_isort_impl.f90 new file mode 100644 index 00000000..a2c30528 --- /dev/null +++ b/base/serial/sort/psb_s_isort_impl.f90 @@ -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 + diff --git a/base/serial/sort/psb_s_msort_impl.f90 b/base/serial/sort/psb_s_msort_impl.f90 new file mode 100644 index 00000000..8e1bf1e4 --- /dev/null +++ b/base/serial/sort/psb_s_msort_impl.f90 @@ -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 + + + + + + + diff --git a/base/serial/sort/psb_s_qsort_impl.f90 b/base/serial/sort/psb_s_qsort_impl.f90 new file mode 100644 index 00000000..66e3de32 --- /dev/null +++ b/base/serial/sort/psb_s_qsort_impl.f90 @@ -0,0 +1,1311 @@ +!!$ +!!$ 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 quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_sqsort(x,ix,dir,flag) + use psb_s_sort_mod, psb_protect_name => psb_sqsort + 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 + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_sqsort' + 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_sqsrx_up(n,x,ix) + case (psb_sort_down_) + call psi_sqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_saqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_saqsrx_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_sqsr_up(n,x) + case (psb_sort_down_) + call psi_sqsr_dw(n,x) + case (psb_asort_up_) + call psi_saqsr_up(n,x) + case (psb_asort_down_) + call psi_saqsr_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_sqsort + + + +subroutine psi_sqsrx_up(n,x,ix) + use psb_s_sort_mod, psb_protect_name => psi_sqsrx_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 + ! .. Local Scalars .. + real(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_sqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_sisrx_up(n,x,indx) + endif +end subroutine psi_sqsrx_up + +subroutine psi_sqsrx_dw(n,x,ix) + use psb_s_sort_mod, psb_protect_name => psi_sqsrx_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 + ! .. Local Scalars .. + real(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_sqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_sisrx_dw(n,x,indx) + endif + +end subroutine psi_sqsrx_dw + +subroutine psi_sqsr_up(n,x) + use psb_s_sort_mod, psb_protect_name => psi_sqsr_up + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + real(psb_spk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_sqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_sisr_up(n,x) + endif + +end subroutine psi_sqsr_up + +subroutine psi_sqsr_dw(n,x) + use psb_s_sort_mod, psb_protect_name => psi_sqsr_dw + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + real(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_sqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_sisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_sisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_sisr_dw(n,x) + endif + +end subroutine psi_sqsr_dw + +subroutine psi_saqsrx_up(n,x,ix) + use psb_s_sort_mod, psb_protect_name => psi_saqsrx_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 + ! .. Local Scalars .. + real(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_saqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_saisrx_up(n,x,indx) + endif + + +end subroutine psi_saqsrx_up + +subroutine psi_saqsrx_dw(n,x,ix) + use psb_s_sort_mod, psb_protect_name => psi_saqsrx_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 + ! .. Local Scalars .. + real(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_saqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_saisrx_dw(n,x,indx) + endif + +end subroutine psi_saqsrx_dw + +subroutine psi_saqsr_up(n,x) + use psb_s_sort_mod, psb_protect_name => psi_saqsr_up + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + real(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_sqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_saisr_up(n,x) + endif + +end subroutine psi_saqsr_up + +subroutine psi_saqsr_dw(n,x) + use psb_s_sort_mod, psb_protect_name => psi_saqsr_dw + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + real(psb_spk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_sqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_saisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_saisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_saisr_dw(n,x) + endif + +end subroutine psi_saqsr_dw + + diff --git a/base/serial/sort/psb_z_hsort_impl.f90 b/base/serial/sort/psb_z_hsort_impl.f90 new file mode 100644 index 00000000..98117a42 --- /dev/null +++ b/base/serial/sort/psb_z_hsort_impl.f90 @@ -0,0 +1,1140 @@ +!!$ +!!$ 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_zhsort(x,ix,dir,flag) + use psb_z_sort_mod, psb_protect_name => psb_zhsort + 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, 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_lsort_up_,psb_lsort_down_,psb_alsort_up_,psb_alsort_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_z_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_z_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_z_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_z_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_zhsort + + + +! +! 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_z_insert_heap(key,last,heap,dir,info) + use psb_z_sort_mod, psb_protect_name => psi_z_insert_heap + 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 + integer(psb_ipk_), intent(in) :: dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2 + complex(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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap) + + case (psb_asort_down_) + call fix_adw(last,heap) + + case (psb_alsort_up_) + call fix_alup(last,heap) + + case (psb_alsort_down_) + call fix_aldw(last,heap) + + case (psb_lsort_up_) + call fix_lup(last,heap) + + case (psb_lsort_down_) + call fix_ldw(last,heap) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return + +contains + + subroutine fix_aup(last,heap) + use psi_acx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_dpk_) :: temp + + i=last + 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 + end subroutine fix_aup + + subroutine fix_adw(last,heap) + use psi_acx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_dpk_) :: temp + + i=last + 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 + end subroutine fix_adw + + + subroutine fix_lup(last,heap) + use psi_lcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_dpk_) :: temp + + i=last + 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 + end subroutine fix_lup + + subroutine fix_ldw(last,heap) + use psi_lcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_dpk_) :: temp + + i=last + 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 + end subroutine fix_ldw + + subroutine fix_alup(last,heap) + use psi_alcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_dpk_) :: temp + + i=last + 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 + end subroutine fix_alup + + subroutine fix_aldw(last,heap) + use psi_alcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2 + complex(psb_dpk_) :: temp + + i=last + 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 + end subroutine fix_aldw + +end subroutine psi_z_insert_heap + +subroutine psi_z_heap_get_first(key,last,heap,dir,info) + use psb_z_sort_mod, psb_protect_name => psi_z_insert_heap + 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(inout) :: 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 + + integer(psb_ipk_) :: i + + 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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap) + + case (psb_asort_down_) + call fix_adw(last,heap) + + case (psb_alsort_up_) + call fix_alup(last,heap) + + case (psb_alsort_down_) + call fix_aldw(last,heap) + + case (psb_lsort_up_) + call fix_lup(last,heap) + + case (psb_lsort_down_) + call fix_ldw(last,heap) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +contains + + subroutine fix_aup(last,heap) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_dpk_) :: temp + + 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 + + end subroutine fix_aup + + + subroutine fix_adw(last,heap) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_dpk_) :: temp + + 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 + + end subroutine fix_adw + + subroutine fix_lup(last,heap) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_dpk_) :: temp + + 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 + + end subroutine fix_lup + + subroutine fix_ldw(last,heap) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_dpk_) :: temp + + 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 + + end subroutine fix_ldw + + subroutine fix_alup(last,heap) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_dpk_) :: temp + + 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 + + end subroutine fix_alup + + subroutine fix_aldw(last,heap) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + + integer(psb_ipk_) :: i,j + complex(psb_dpk_) :: temp + + 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 + + end subroutine fix_aldw + +end subroutine psi_z_heap_get_first + +subroutine psi_z_idx_insert_heap(key,index,last,heap,idxs,dir,info) + use psb_z_sort_mod, psb_protect_name => psi_z_idx_insert_idx_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 + + 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(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2, itemp + complex(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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap,idxs) + + case (psb_asort_down_) + call fix_adw(last,heap,idxs) + + case (psb_alsort_up_) + call fix_alup(last,heap,idxs) + + case (psb_alsort_down_) + call fix_aldw(last,heap,idxs) + + case (psb_lsort_up_) + call fix_lup(last,heap,idxs) + + case (psb_lsort_down_) + call fix_ldw(last,heap,idxs) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return + +contains + + subroutine fix_aup(last,heap,idxs) + use psi_acx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_dpk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_aup + + subroutine fix_adw(last,heap,idxs) + use psi_acx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_dpk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_adw + + + subroutine fix_lup(last,heap,idxs) + use psi_lcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_dpk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_lup + + subroutine fix_ldw(last,heap,idxs) + use psi_lcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_dpk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_ldw + + subroutine fix_alup(last,heap,idxs) + use psi_alcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_dpk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_alup + + subroutine fix_aldw(last,heap,idxs) + use psi_alcx_mod + implicit none + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_) :: i, i2, itemp + complex(psb_dpk_) :: temp + + i=last + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + i = i2 + else + exit + end if + end do + end subroutine fix_aldw + +end subroutine psi_z_idx_insert_heap + + + +subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_z_sort_mod, psb_protect_name => psi_z_insert_heap + 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(inout) :: key + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(in) :: dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i + + 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_, psb_sort_down_) + info = -4 + + case (psb_asort_up_) + call fix_aup(last,heap) + + case (psb_asort_down_) + call fix_adw(last,heap) + + case (psb_alsort_up_) + call fix_alup(last,heap) + + case (psb_alsort_down_) + call fix_aldw(last,heap) + + case (psb_lsort_up_) + call fix_lup(last,heap) + + case (psb_lsort_down_) + call fix_ldw(last,heap) + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +contains + + subroutine fix_aup(last,heap,idxs) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_dpk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_aup + + + subroutine fix_adw(last,heap,idxs) + use psi_acx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_dpk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_adw + + subroutine fix_lup(last,heap,idxs) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_dpk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_lup + + subroutine fix_ldw(last,heap,idxs) + use psi_lcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_dpk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_ldw + + subroutine fix_alup(last,heap,idxs) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_dpk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_alup + + subroutine fix_aldw(last,heap,idxs) + use psi_alcx_mod + integer(psb_ipk_), intent(in) :: last + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk) :: idxs(:) + + integer(psb_ipk_) :: i,j, itemp + complex(psb_dpk_) :: temp + + 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 + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + i = j + else + exit + end if + end do + + end subroutine fix_aldw + +end subroutine psi_z_heap_get_first + + + diff --git a/base/serial/sort/psb_z_isort_impl.f90 b/base/serial/sort/psb_z_isort_impl.f90 new file mode 100644 index 00000000..3e5ae436 --- /dev/null +++ b/base/serial/sort/psb_z_isort_impl.f90 @@ -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 + diff --git a/base/serial/sort/psb_z_msort_impl.f90 b/base/serial/sort/psb_z_msort_impl.f90 new file mode 100644 index 00000000..40920ded --- /dev/null +++ b/base/serial/sort/psb_z_msort_impl.f90 @@ -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 diff --git a/base/serial/sort/psb_z_qsort_impl.f90 b/base/serial/sort/psb_z_qsort_impl.f90 new file mode 100644 index 00000000..9823b086 --- /dev/null +++ b/base/serial/sort/psb_z_qsort_impl.f90 @@ -0,0 +1,2505 @@ +!!$ +!!$ 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 quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_zqsort(x,ix,dir,flag) + use psb_z_sort_mod, psb_protect_name => psb_zqsort + 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 + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_zqsort' + 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_zlqsrx_up(n,x,ix) + case (psb_lsort_down_) + call psi_zlqsrx_dw(n,x,ix) + case (psb_alsort_up_) + call psi_zalqsrx_up(n,x,ix) + case (psb_alsort_down_) + call psi_zalqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_zaqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_zaqsrx_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_zlqsr_up(n,x) + case (psb_lsort_down_) + call psi_zlqsr_dw(n,x) + case (psb_alsort_up_) + call psi_zalqsr_up(n,x) + case (psb_alsort_down_) + call psi_zalqsr_dw(n,x) + case (psb_asort_up_) + call psi_zaqsr_up(n,x) + case (psb_asort_down_) + call psi_zaqsr_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_zqsort + + + +subroutine psi_zqsrx_up(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zisrx_up(n,x,indx) + endif +end subroutine psi_zqsrx_up + +subroutine psi_zqsrx_dw(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zisrx_dw(n,x,indx) + endif + +end subroutine psi_zqsrx_dw + +subroutine psi_zqsr_up(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zqsr_up + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zisr_up(n,x) + endif + +end subroutine psi_zqsr_up + +subroutine psi_zqsr_dw(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zqsr_dw + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_zqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zisr_dw(n,x) + endif + +end subroutine psi_zqsr_dw + +@NOTCE@ +subroutine psi_zlqsrx_up(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zlqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zlisrx_up(n,x,indx) + endif + +end subroutine psi_zlqsrx_up + +subroutine psi_zlqsrx_dw(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zlqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zlisrx_dw(n,x,indx) + endif +end subroutine psi_zlqsrx_dw + +subroutine psi_zlqsr_up(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zlqsr_up + use psb_error_mod + use psi_lcx_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zlisr_up(n,x) + endif + +end subroutine psi_zlqsr_up + +subroutine psi_zlqsr_dw(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zlqsr_dw + use psb_error_mod + use psi_lcx_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_zqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zlisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zlisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zlisr_dw(n,x) + endif + +end subroutine psi_zlqsr_dw + +subroutine psi_zalqsrx_up(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zalqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zalisrx_up(n,x,indx) + endif +end subroutine psi_zalqsrx_up + +subroutine psi_zalqsrx_dw(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zalqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zalisrx_dw(n,x,indx) + endif +end subroutine psi_zalqsrx_dw + +subroutine psi_zalqsr_up(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zalqsr_up + use psb_error_mod + use psi_alcx_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zalisr_up(n,x) + endif +end subroutine psi_zalqsr_up + +subroutine psi_zalqsr_dw(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zalqsr_dw + use psb_error_mod + use psi_alcx_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_zqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zalisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zalisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zalisr_dw(n,x) + endif +end subroutine psi_zalqsr_dw + +subroutine psi_zaqsrx_up(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zaqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_zaqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zaisrx_up(n,x,indx) + endif + + +end subroutine psi_zaqsrx_up + +subroutine psi_zaqsrx_dw(n,x,ix) + use psb_z_sort_mod, psb_protect_name => psi_zaqsrx_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 + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zaqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call psi_zaisrx_dw(n,x,indx) + endif + +end subroutine psi_zaqsrx_dw + +subroutine psi_zaqsr_up(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zaqsr_up + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_zqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zaisr_up(n,x) + endif + +end subroutine psi_zaqsr_up + +subroutine psi_zaqsr_dw(n,x) + use psb_z_sort_mod, psb_protect_name => psi_zaqsr_dw + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + complex(psb_dpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: ixt, n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_zqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_zaisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_zaisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_zaisr_dw(n,x) + endif + +end subroutine psi_zaqsr_dw + + diff --git a/base/serial/aux/psi_acx_mod.f90 b/base/serial/sort/psi_acx_mod.f90 similarity index 100% rename from base/serial/aux/psi_acx_mod.f90 rename to base/serial/sort/psi_acx_mod.f90 diff --git a/base/serial/aux/psi_alcx_mod.f90 b/base/serial/sort/psi_alcx_mod.f90 similarity index 100% rename from base/serial/aux/psi_alcx_mod.f90 rename to base/serial/sort/psi_alcx_mod.f90 diff --git a/base/serial/aux/psi_lcx_mod.f90 b/base/serial/sort/psi_lcx_mod.f90 similarity index 100% rename from base/serial/aux/psi_lcx_mod.f90 rename to base/serial/sort/psi_lcx_mod.f90 diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index d0dc36f5..76cca5d2 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -1,5 +1,5 @@ 7 Number of entries below this -BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES +BICG STAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES BJAC Preconditioner NONE DIAG BJAC CSR Storage format for matrix A: CSR COO JAD 100 Domain size (acutal system is this**3)