From 26906c1efc99ef2b1a3473224cadcf03e4d4fa1d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 2 May 2015 19:19:51 +0000 Subject: [PATCH] psblas3: base/modules/Makefile base/modules/psb_c_sort_mod.f90 base/modules/psb_d_sort_mod.f90 base/modules/psb_i_sort_mod.f90 base/modules/psb_s_sort_mod.f90 base/modules/psb_sort_mod.f90 base/modules/psb_z_sort_mod.f90 base/serial/Makefile base/serial/aux/Makefile base/serial/impl/psb_c_coo_impl.f90 base/serial/impl/psb_c_csc_impl.f90 base/serial/impl/psb_c_csr_impl.f90 base/serial/impl/psb_d_coo_impl.f90 base/serial/impl/psb_d_csc_impl.f90 base/serial/impl/psb_d_csr_impl.f90 base/serial/impl/psb_s_coo_impl.f90 base/serial/impl/psb_s_csc_impl.f90 base/serial/impl/psb_s_csr_impl.f90 base/serial/impl/psb_z_coo_impl.f90 base/serial/impl/psb_z_csc_impl.f90 base/serial/impl/psb_z_csr_impl.f90 base/serial/sort/Makefile base/serial/sort/psb_c_hsort_impl.f90 base/serial/sort/psb_c_isort_impl.f90 base/serial/sort/psb_c_msort_impl.f90 base/serial/sort/psb_c_qsort_impl.f90 base/serial/sort/psb_d_hsort_impl.f90 base/serial/sort/psb_d_isort_impl.f90 base/serial/sort/psb_d_msort_impl.f90 base/serial/sort/psb_d_qsort_impl.f90 base/serial/sort/psb_i_hsort_impl.f90 base/serial/sort/psb_i_isort_impl.f90 base/serial/sort/psb_i_msort_impl.f90 base/serial/sort/psb_i_qsort_impl.f90 base/serial/sort/psb_s_isort_impl.f90 base/serial/sort/psb_s_msort_impl.f90 base/serial/sort/psb_s_qsort_impl.f90 base/serial/sort/psb_z_hsort_impl.f90 base/serial/sort/psb_z_isort_impl.f90 base/serial/sort/psb_z_msort_impl.f90 base/serial/sort/psb_z_qsort_impl.f90 base/serial/sort/psi_alcx_mod.f90 New sort implementations. Fix all methods calling them. --- base/modules/Makefile | 2 + base/modules/psb_c_sort_mod.f90 | 48 + base/modules/psb_d_sort_mod.f90 | 34 + base/modules/psb_i_sort_mod.f90 | 34 + base/modules/psb_s_sort_mod.f90 | 34 + base/modules/psb_sort_mod.f90 | 1399 +++++++++++++------------ base/modules/psb_z_sort_mod.f90 | 48 + base/serial/Makefile | 9 +- base/serial/aux/Makefile | 25 +- base/serial/impl/psb_c_coo_impl.f90 | 16 +- base/serial/impl/psb_c_csc_impl.f90 | 1 - base/serial/impl/psb_c_csr_impl.f90 | 1 - base/serial/impl/psb_d_coo_impl.f90 | 16 +- base/serial/impl/psb_d_csc_impl.f90 | 1 - base/serial/impl/psb_d_csr_impl.f90 | 1 - base/serial/impl/psb_s_coo_impl.f90 | 16 +- base/serial/impl/psb_s_csc_impl.f90 | 1 - base/serial/impl/psb_s_csr_impl.f90 | 1 - base/serial/impl/psb_z_coo_impl.f90 | 16 +- base/serial/impl/psb_z_csc_impl.f90 | 1 - base/serial/impl/psb_z_csr_impl.f90 | 1 - base/serial/sort/Makefile | 3 +- base/serial/sort/psb_c_hsort_impl.f90 | 34 +- base/serial/sort/psb_c_isort_impl.f90 | 24 +- base/serial/sort/psb_c_msort_impl.f90 | 218 ++-- base/serial/sort/psb_c_qsort_impl.f90 | 1023 ++++-------------- base/serial/sort/psb_d_hsort_impl.f90 | 2 +- base/serial/sort/psb_d_isort_impl.f90 | 16 +- base/serial/sort/psb_d_msort_impl.f90 | 213 ++-- base/serial/sort/psb_d_qsort_impl.f90 | 286 ++--- base/serial/sort/psb_i_hsort_impl.f90 | 2 +- base/serial/sort/psb_i_isort_impl.f90 | 16 +- base/serial/sort/psb_i_msort_impl.f90 | 553 +++++----- base/serial/sort/psb_i_qsort_impl.f90 | 286 ++--- base/serial/sort/psb_s_isort_impl.f90 | 16 +- base/serial/sort/psb_s_msort_impl.f90 | 213 ++-- base/serial/sort/psb_s_qsort_impl.f90 | 286 ++--- base/serial/sort/psb_z_hsort_impl.f90 | 34 +- base/serial/sort/psb_z_isort_impl.f90 | 24 +- base/serial/sort/psb_z_msort_impl.f90 | 218 ++-- base/serial/sort/psb_z_qsort_impl.f90 | 1023 ++++-------------- base/serial/sort/psi_alcx_mod.f90 | 4 +- 42 files changed, 2617 insertions(+), 3582 deletions(-) diff --git a/base/modules/Makefile b/base/modules/Makefile index 0e2f8987..0ccf1133 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -138,6 +138,8 @@ psb_s_comm_mod.o: psb_s_vect_mod.o psb_desc_mod.o psb_mat_mod.o psb_d_comm_mod.o: psb_d_vect_mod.o psb_desc_mod.o psb_mat_mod.o psb_c_comm_mod.o: psb_c_vect_mod.o psb_desc_mod.o psb_mat_mod.o psb_z_comm_mod.o: psb_z_vect_mod.o psb_desc_mod.o psb_mat_mod.o +psb_sort_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_base_mod.o: $(MODULES) diff --git a/base/modules/psb_c_sort_mod.f90 b/base/modules/psb_c_sort_mod.f90 index 967fa151..ee8c0d16 100644 --- a/base/modules/psb_c_sort_mod.f90 +++ b/base/modules/psb_c_sort_mod.f90 @@ -79,6 +79,54 @@ module psb_c_sort_mod end subroutine psb_cmsort end interface psb_msort + interface + subroutine psi_c_lmsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_lmsort_up + subroutine psi_c_lmsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_lmsort_dw + subroutine psi_c_almsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_almsort_up + subroutine psi_c_almsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_almsort_dw + end interface + interface + subroutine psi_c_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_amsort_up + subroutine psi_c_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_amsort_dw + end interface + + interface psb_qsort subroutine psb_cqsort(x,ix,dir,flag) import diff --git a/base/modules/psb_d_sort_mod.f90 b/base/modules/psb_d_sort_mod.f90 index 4b2b86b5..1352a10a 100644 --- a/base/modules/psb_d_sort_mod.f90 +++ b/base/modules/psb_d_sort_mod.f90 @@ -79,6 +79,40 @@ module psb_d_sort_mod end subroutine psb_dmsort end interface psb_msort + interface + subroutine psi_d_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_msort_up + subroutine psi_d_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_msort_dw + end interface + interface + subroutine psi_d_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_amsort_up + subroutine psi_d_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_amsort_dw + end interface + + interface psb_qsort subroutine psb_dqsort(x,ix,dir,flag) import diff --git a/base/modules/psb_i_sort_mod.f90 b/base/modules/psb_i_sort_mod.f90 index 06bbb095..f4b9e925 100644 --- a/base/modules/psb_i_sort_mod.f90 +++ b/base/modules/psb_i_sort_mod.f90 @@ -120,6 +120,40 @@ module psb_i_sort_mod end subroutine psb_imsort end interface psb_msort + interface + subroutine psi_i_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_ipk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i_msort_up + subroutine psi_i_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_ipk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i_msort_dw + end interface + interface + subroutine psi_i_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_ipk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i_amsort_up + subroutine psi_i_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_ipk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i_amsort_dw + end interface + + interface psb_qsort subroutine psb_iqsort(x,ix,dir,flag) import diff --git a/base/modules/psb_s_sort_mod.f90 b/base/modules/psb_s_sort_mod.f90 index a37a4a60..273c4116 100644 --- a/base/modules/psb_s_sort_mod.f90 +++ b/base/modules/psb_s_sort_mod.f90 @@ -79,6 +79,40 @@ module psb_s_sort_mod end subroutine psb_smsort end interface psb_msort + interface + subroutine psi_s_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_msort_up + subroutine psi_s_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_msort_dw + end interface + interface + subroutine psi_s_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_amsort_up + subroutine psi_s_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_amsort_dw + end interface + + interface psb_qsort subroutine psb_sqsort(x,ix,dir,flag) import diff --git a/base/modules/psb_sort_mod.f90 b/base/modules/psb_sort_mod.f90 index edf7a85d..49a95e08 100644 --- a/base/modules/psb_sort_mod.f90 +++ b/base/modules/psb_sort_mod.f90 @@ -41,701 +41,712 @@ ! Data Structures and Algorithms ! Addison-Wesley ! + module psb_sort_mod use psb_const_mod - - - type psb_int_heap - integer(psb_ipk_) :: last, dir - integer(psb_ipk_), allocatable :: keys(:) - end type psb_int_heap - type psb_int_idx_heap - integer(psb_ipk_) :: last, dir - integer(psb_ipk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - end type psb_int_idx_heap - type psb_sreal_idx_heap - integer(psb_ipk_) :: last, dir - real(psb_spk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - end type psb_sreal_idx_heap - type psb_dreal_idx_heap - integer(psb_ipk_) :: last, dir - real(psb_dpk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - end type psb_dreal_idx_heap - type psb_scomplex_idx_heap - integer(psb_ipk_) :: last, dir - complex(psb_spk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - end type psb_scomplex_idx_heap - type psb_dcomplex_idx_heap - integer(psb_ipk_) :: last, dir - complex(psb_dpk_), allocatable :: keys(:) - integer(psb_ipk_), allocatable :: idxs(:) - end type psb_dcomplex_idx_heap - - - interface psb_iblsrch - function psb_iblsrch(key,n,v) result(ipos) - import :: psb_ipk_ - integer(psb_ipk_) :: ipos, key, n - integer(psb_ipk_) :: v(:) - end function psb_iblsrch - end interface - - interface psb_ibsrch - function psb_ibsrch(key,n,v) result(ipos) - import :: psb_ipk_ - integer(psb_ipk_) :: ipos, key, n - integer(psb_ipk_) :: v(:) - end function psb_ibsrch - end interface - - interface psb_issrch - function psb_issrch(key,n,v) result(ipos) - import :: psb_ipk_ - implicit none - integer(psb_ipk_) :: ipos, key, n - integer(psb_ipk_) :: v(:) - end function psb_issrch - end interface - - interface psb_isaperm - logical function psb_isaperm(n,eip) - import :: psb_ipk_ - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: eip(n) - end function psb_isaperm - end interface - - - interface psb_msort - subroutine imsort(x,ix,dir,flag) - import :: psb_ipk_ - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine imsort - subroutine smsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine smsort - subroutine dmsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine dmsort - subroutine camsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine camsort - subroutine zamsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine zamsort - end interface - - - interface psb_msort_unique - subroutine imsort_u(x,nout,dir) - import :: psb_ipk_, psb_spk_, psb_dpk_ - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: nout - integer(psb_ipk_), optional, intent(in) :: dir - end subroutine imsort_u - end interface - - interface psb_qsort - subroutine iqsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine iqsort - subroutine sqsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine sqsort - subroutine dqsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine dqsort - subroutine cqsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine cqsort - subroutine zqsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine zqsort - end interface - - - interface psb_hsort - subroutine ihsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine ihsort - subroutine shsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - real(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine shsort - subroutine dhsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine dhsort - subroutine chsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine chsort - subroutine zhsort(x,ix,dir,flag) - import :: psb_ipk_, psb_spk_, psb_dpk_ - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_ipk_), optional, intent(in) :: dir, flag - integer(psb_ipk_), optional, intent(inout) :: ix(:) - end subroutine zhsort - end interface - - - interface psb_howmany_heap - function psb_howmany_int_heap(heap) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_int_heap - type(psb_int_heap), intent(in) :: heap - integer(psb_ipk_) :: psb_howmany_int_heap - end function psb_howmany_int_heap - function psb_howmany_sreal_idx_heap(heap) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_sreal_idx_heap - type(psb_sreal_idx_heap), intent(in) :: heap - integer(psb_ipk_) :: psb_howmany_sreal_idx_heap - end function psb_howmany_sreal_idx_heap - function psb_howmany_dreal_idx_heap(heap) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_dreal_idx_heap - type(psb_dreal_idx_heap), intent(in) :: heap - integer(psb_ipk_) :: psb_howmany_dreal_idx_heap - end function psb_howmany_dreal_idx_heap - function psb_howmany_int_idx_heap(heap) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_int_idx_heap - type(psb_int_idx_heap), intent(in) :: heap - integer(psb_ipk_) :: psb_howmany_int_idx_heap - end function psb_howmany_int_idx_heap - function psb_howmany_scomplex_idx_heap(heap) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_scomplex_idx_heap - type(psb_scomplex_idx_heap), intent(in) :: heap - integer(psb_ipk_) :: psb_howmany_scomplex_idx_heap - end function psb_howmany_scomplex_idx_heap - function psb_howmany_dcomplex_idx_heap(heap) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_dcomplex_idx_heap - type(psb_dcomplex_idx_heap), intent(in) :: heap - integer(psb_ipk_) :: psb_howmany_dcomplex_idx_heap - end function psb_howmany_dcomplex_idx_heap - end interface - - - interface psb_init_heap - subroutine psb_init_int_heap(heap,info,dir) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_int_heap - type(psb_int_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - end subroutine psb_init_int_heap - subroutine psb_init_sreal_idx_heap(heap,info,dir) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_sreal_idx_heap - type(psb_sreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - end subroutine psb_init_sreal_idx_heap - subroutine psb_init_int_idx_heap(heap,info,dir) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_int_idx_heap - type(psb_int_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - end subroutine psb_init_int_idx_heap - subroutine psb_init_scomplex_idx_heap(heap,info,dir) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_scomplex_idx_heap - type(psb_scomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - end subroutine psb_init_scomplex_idx_heap - subroutine psb_init_dcomplex_idx_heap(heap,info,dir) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_dcomplex_idx_heap - type(psb_dcomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - end subroutine psb_init_dcomplex_idx_heap - subroutine psb_init_dreal_idx_heap(heap,info,dir) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_dreal_idx_heap - type(psb_dreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: dir - end subroutine psb_init_dreal_idx_heap - end interface - - - interface psb_dump_heap - subroutine psb_dump_int_heap(iout,heap,info) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_int_heap - type(psb_int_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - end subroutine psb_dump_int_heap - subroutine psb_dump_sreal_idx_heap(iout,heap,info) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_sreal_idx_heap - type(psb_sreal_idx_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - end subroutine psb_dump_sreal_idx_heap - subroutine psb_dump_dreal_idx_heap(iout,heap,info) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_dreal_idx_heap - type(psb_dreal_idx_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - end subroutine psb_dump_dreal_idx_heap - subroutine psb_dump_int_idx_heap(iout,heap,info) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_int_idx_heap - type(psb_int_idx_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - end subroutine psb_dump_int_idx_heap - subroutine psb_dump_scomplex_idx_heap(iout,heap,info) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_scomplex_idx_heap - type(psb_scomplex_idx_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - end subroutine psb_dump_scomplex_idx_heap - subroutine psb_dump_dcomplex_idx_heap(iout,heap,info) - import :: psb_ipk_, psb_spk_, psb_dpk_ - import :: psb_dcomplex_idx_heap - type(psb_dcomplex_idx_heap), intent(in) :: heap - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iout - end subroutine psb_dump_dcomplex_idx_heap - end interface - - - interface psb_insert_heap - subroutine psb_insert_int_heap(key,heap,info) - import :: psb_int_heap, psb_ipk_ - integer(psb_ipk_), intent(in) :: key - type(psb_int_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - end subroutine psb_insert_int_heap - subroutine psb_insert_int_idx_heap(key,index,heap,info) - import :: psb_dpk_, psb_int_idx_heap, psb_ipk_ - integer(psb_ipk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index - type(psb_int_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - end subroutine psb_insert_int_idx_heap - subroutine psb_insert_sreal_idx_heap(key,index,heap,info) - import :: psb_spk_, psb_sreal_idx_heap, psb_ipk_ - real(psb_spk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index - type(psb_sreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - end subroutine psb_insert_sreal_idx_heap - subroutine psb_insert_dreal_idx_heap(key,index,heap,info) - import :: psb_dpk_, psb_dreal_idx_heap, psb_ipk_ - real(psb_dpk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index - type(psb_dreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - end subroutine psb_insert_dreal_idx_heap - subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) - import :: psb_spk_, psb_scomplex_idx_heap, psb_ipk_ - complex(psb_spk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index - type(psb_scomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - end subroutine psb_insert_scomplex_idx_heap - subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info) - import :: psb_dpk_, psb_dcomplex_idx_heap, psb_ipk_ - complex(psb_dpk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index - type(psb_dcomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - end subroutine psb_insert_dcomplex_idx_heap - end interface - - interface psb_heap_get_first - subroutine psb_int_heap_get_first(key,heap,info) - import :: psb_int_heap, psb_ipk_ - type(psb_int_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: key,info - end subroutine psb_int_heap_get_first - subroutine psb_int_idx_heap_get_first(key,index,heap,info) - import :: psb_int_idx_heap, psb_ipk_ - type(psb_int_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info - integer(psb_ipk_), intent(out) :: key - end subroutine psb_int_idx_heap_get_first - subroutine psb_sreal_idx_heap_get_first(key,index,heap,info) - import :: psb_spk_, psb_sreal_idx_heap, psb_ipk_ - type(psb_sreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info - real(psb_spk_), intent(out) :: key - end subroutine psb_sreal_idx_heap_get_first - subroutine psb_dreal_idx_heap_get_first(key,index,heap,info) - import :: psb_dpk_, psb_dreal_idx_heap, psb_ipk_ - type(psb_dreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info - real(psb_dpk_), intent(out) :: key - end subroutine psb_dreal_idx_heap_get_first - subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info) - import :: psb_spk_, psb_scomplex_idx_heap, psb_ipk_ - type(psb_scomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info - complex(psb_spk_), intent(out) :: key - end subroutine psb_scomplex_idx_heap_get_first - - subroutine psb_dcomplex_idx_heap_get_first(key,index,heap,info) - import :: psb_dpk_, psb_dcomplex_idx_heap, psb_ipk_ - type(psb_dcomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info - complex(psb_dpk_), intent(out) :: key - end subroutine psb_dcomplex_idx_heap_get_first - end interface - - interface - subroutine psi_insert_int_heap(key,last,heap,dir,info) - import :: psb_ipk_ - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - integer(psb_ipk_), intent(in) :: key,dir - integer(psb_ipk_), intent(inout) :: heap(:),last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_int_heap - end interface - - interface - subroutine psi_int_heap_get_first(key,last,heap,dir,info) - import :: psb_ipk_ - implicit none - - integer(psb_ipk_), intent(inout) :: key,last - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_int_heap_get_first - end interface - - interface - subroutine psi_insert_real_heap(key,last,heap,dir,info) - import :: psb_spk_, psb_ipk_ - real(psb_spk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: dir - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_real_heap - end interface - - interface - subroutine psi_real_heap_get_first(key,last,heap,dir,info) - import :: psb_spk_, psb_ipk_ - real(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_real_heap_get_first - end interface - - interface - subroutine psi_insert_double_heap(key,last,heap,dir,info) - import :: psb_dpk_, psb_ipk_ - real(psb_dpk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: dir - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_double_heap - end interface - - interface - subroutine psi_double_heap_get_first(key,last,heap,dir,info) - import :: psb_dpk_, psb_ipk_ - real(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_double_heap_get_first - end interface - - interface - subroutine psi_insert_scomplex_heap(key,last,heap,dir,info) - import :: psb_spk_, psb_ipk_ - complex(psb_spk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: dir - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_scomplex_heap - end interface - - interface - subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info) - import :: psb_spk_, psb_ipk_ - complex(psb_spk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_scomplex_heap_get_first - end interface - - interface - subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info) - import :: psb_dpk_, psb_ipk_ - complex(psb_dpk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: dir - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_dcomplex_heap - end interface - - interface - subroutine psi_dcomplex_heap_get_first(key,last,heap,dir,info) - import :: psb_dpk_, psb_ipk_ - complex(psb_dpk_), intent(inout) :: key - integer(psb_ipk_), intent(inout) :: last - integer(psb_ipk_), intent(in) :: dir - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_dcomplex_heap_get_first - end interface - - interface - subroutine psi_insert_int_idx_heap(key,index,last,heap,idxs,dir,info) - import :: psb_ipk_ - integer(psb_ipk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir - integer(psb_ipk_), intent(inout) :: heap(:),last - integer(psb_ipk_), intent(inout) :: idxs(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_int_idx_heap - end interface - - interface - subroutine psi_int_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import :: psb_ipk_ - integer(psb_ipk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info - integer(psb_ipk_), intent(inout) :: last,idxs(:) - integer(psb_ipk_), intent(in) :: dir - integer(psb_ipk_), intent(out) :: key - end subroutine psi_int_idx_heap_get_first - end interface - - interface - subroutine psi_insert_sreal_idx_heap(key,index,last,heap,idxs,dir,info) - import :: psb_spk_, psb_ipk_ - real(psb_spk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: idxs(:),last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_sreal_idx_heap - end interface - - interface - subroutine psi_sreal_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import :: psb_spk_, psb_ipk_ - real(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info - integer(psb_ipk_), intent(inout) :: last,idxs(:) - integer(psb_ipk_), intent(in) :: dir - real(psb_spk_), intent(out) :: key - end subroutine psi_sreal_idx_heap_get_first - end interface - - interface - subroutine psi_insert_dreal_idx_heap(key,index,last,heap,idxs,dir,info) - import :: psb_dpk_, psb_ipk_ - real(psb_dpk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: idxs(:),last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_dreal_idx_heap - end interface - - interface - subroutine psi_dreal_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import :: psb_dpk_, psb_ipk_ - real(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info - integer(psb_ipk_), intent(inout) :: last,idxs(:) - integer(psb_ipk_), intent(in) :: dir - real(psb_dpk_), intent(out) :: key - end subroutine psi_dreal_idx_heap_get_first - end interface - - interface - subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info) - import :: psb_spk_, psb_ipk_ - complex(psb_spk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: idxs(:),last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_scomplex_idx_heap - end interface - - interface - subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import :: psb_spk_, psb_ipk_ - complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info - integer(psb_ipk_), intent(inout) :: last,idxs(:) - integer(psb_ipk_), intent(in) :: dir - complex(psb_spk_), intent(out) :: key - end subroutine psi_scomplex_idx_heap_get_first - end interface - - interface - subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info) - import :: psb_dpk_, psb_ipk_ - complex(psb_dpk_), intent(in) :: key - integer(psb_ipk_), intent(in) :: index,dir - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(inout) :: idxs(:),last - integer(psb_ipk_), intent(out) :: info - end subroutine psi_insert_dcomplex_idx_heap - end interface - - interface - subroutine psi_dcomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - import :: psb_dpk_, psb_ipk_ - complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk_), intent(out) :: index,info - integer(psb_ipk_), intent(inout) :: last,idxs(:) - integer(psb_ipk_), intent(in) :: dir - complex(psb_dpk_), intent(out) :: key - end subroutine psi_dcomplex_idx_heap_get_first - end interface - - - interface psb_free_heap - module procedure psb_free_int_heap, psb_free_int_idx_heap,& - & psb_free_sreal_idx_heap, psb_free_scomplex_idx_heap, & - & psb_free_dreal_idx_heap, psb_free_dcomplex_idx_heap - end interface - -contains - - subroutine psb_free_int_heap(heap,info) - implicit none - type(psb_int_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info=psb_success_ - if (allocated(heap%keys)) deallocate(heap%keys,stat=info) - - end subroutine psb_free_int_heap - - subroutine psb_free_sreal_idx_heap(heap,info) - implicit none - type(psb_sreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info=psb_success_ - if (allocated(heap%keys)) deallocate(heap%keys,stat=info) - if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) - - end subroutine psb_free_sreal_idx_heap - - subroutine psb_free_dreal_idx_heap(heap,info) - implicit none - type(psb_dreal_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info=psb_success_ - if (allocated(heap%keys)) deallocate(heap%keys,stat=info) - if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) - - end subroutine psb_free_dreal_idx_heap - - subroutine psb_free_int_idx_heap(heap,info) - implicit none - type(psb_int_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info=psb_success_ - if (allocated(heap%keys)) deallocate(heap%keys,stat=info) - if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) - - end subroutine psb_free_int_idx_heap - - subroutine psb_free_scomplex_idx_heap(heap,info) - implicit none - type(psb_scomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info=psb_success_ - if (allocated(heap%keys)) deallocate(heap%keys,stat=info) - if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) - - end subroutine psb_free_scomplex_idx_heap - - subroutine psb_free_dcomplex_idx_heap(heap,info) - implicit none - type(psb_dcomplex_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: info - - info=psb_success_ - if (allocated(heap%keys)) deallocate(heap%keys,stat=info) - if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) - - end subroutine psb_free_dcomplex_idx_heap + use psb_ip_reord_mod + use psb_i_sort_mod + use psb_s_sort_mod + use psb_c_sort_mod + use psb_d_sort_mod + use psb_z_sort_mod + +!!$module psb_sort_mod +!!$ use psb_const_mod +!!$ +!!$ +!!$ type psb_int_heap +!!$ integer(psb_ipk_) :: last, dir +!!$ integer(psb_ipk_), allocatable :: keys(:) +!!$ end type psb_int_heap +!!$ type psb_int_idx_heap +!!$ integer(psb_ipk_) :: last, dir +!!$ integer(psb_ipk_), allocatable :: keys(:) +!!$ integer(psb_ipk_), allocatable :: idxs(:) +!!$ end type psb_int_idx_heap +!!$ type psb_sreal_idx_heap +!!$ integer(psb_ipk_) :: last, dir +!!$ real(psb_spk_), allocatable :: keys(:) +!!$ integer(psb_ipk_), allocatable :: idxs(:) +!!$ end type psb_sreal_idx_heap +!!$ type psb_dreal_idx_heap +!!$ integer(psb_ipk_) :: last, dir +!!$ real(psb_dpk_), allocatable :: keys(:) +!!$ integer(psb_ipk_), allocatable :: idxs(:) +!!$ end type psb_dreal_idx_heap +!!$ type psb_scomplex_idx_heap +!!$ integer(psb_ipk_) :: last, dir +!!$ complex(psb_spk_), allocatable :: keys(:) +!!$ integer(psb_ipk_), allocatable :: idxs(:) +!!$ end type psb_scomplex_idx_heap +!!$ type psb_dcomplex_idx_heap +!!$ integer(psb_ipk_) :: last, dir +!!$ complex(psb_dpk_), allocatable :: keys(:) +!!$ integer(psb_ipk_), allocatable :: idxs(:) +!!$ end type psb_dcomplex_idx_heap +!!$ +!!$ +!!$ interface psb_iblsrch +!!$ function psb_iblsrch(key,n,v) result(ipos) +!!$ import :: psb_ipk_ +!!$ integer(psb_ipk_) :: ipos, key, n +!!$ integer(psb_ipk_) :: v(:) +!!$ end function psb_iblsrch +!!$ end interface +!!$ +!!$ interface psb_ibsrch +!!$ function psb_ibsrch(key,n,v) result(ipos) +!!$ import :: psb_ipk_ +!!$ integer(psb_ipk_) :: ipos, key, n +!!$ integer(psb_ipk_) :: v(:) +!!$ end function psb_ibsrch +!!$ end interface +!!$ +!!$ interface psb_issrch +!!$ function psb_issrch(key,n,v) result(ipos) +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ integer(psb_ipk_) :: ipos, key, n +!!$ integer(psb_ipk_) :: v(:) +!!$ end function psb_issrch +!!$ end interface +!!$ +!!$ interface psb_isaperm +!!$ logical function psb_isaperm(n,eip) +!!$ import :: psb_ipk_ +!!$ integer(psb_ipk_), intent(in) :: n +!!$ integer(psb_ipk_), intent(in) :: eip(n) +!!$ end function psb_isaperm +!!$ end interface +!!$ +!!$ +!!$ interface psb_msort +!!$ subroutine imsort(x,ix,dir,flag) +!!$ import :: psb_ipk_ +!!$ integer(psb_ipk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine imsort +!!$ subroutine smsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ real(psb_spk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine smsort +!!$ subroutine dmsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ real(psb_dpk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine dmsort +!!$ subroutine camsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ complex(psb_spk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine camsort +!!$ subroutine zamsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ complex(psb_dpk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine zamsort +!!$ end interface +!!$ +!!$ +!!$ interface psb_msort_unique +!!$ subroutine imsort_u(x,nout,dir) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ integer(psb_ipk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), intent(out) :: nout +!!$ integer(psb_ipk_), optional, intent(in) :: dir +!!$ end subroutine imsort_u +!!$ end interface +!!$ +!!$ interface psb_qsort +!!$ subroutine iqsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ integer(psb_ipk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine iqsort +!!$ subroutine sqsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ real(psb_spk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine sqsort +!!$ subroutine dqsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ real(psb_dpk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine dqsort +!!$ subroutine cqsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ complex(psb_spk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine cqsort +!!$ subroutine zqsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ complex(psb_dpk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine zqsort +!!$ end interface +!!$ +!!$ +!!$ interface psb_hsort +!!$ subroutine ihsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ integer(psb_ipk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine ihsort +!!$ subroutine shsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ real(psb_spk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine shsort +!!$ subroutine dhsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ real(psb_dpk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine dhsort +!!$ subroutine chsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ complex(psb_spk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine chsort +!!$ subroutine zhsort(x,ix,dir,flag) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ complex(psb_dpk_), intent(inout) :: x(:) +!!$ integer(psb_ipk_), optional, intent(in) :: dir, flag +!!$ integer(psb_ipk_), optional, intent(inout) :: ix(:) +!!$ end subroutine zhsort +!!$ end interface +!!$ +!!$ +!!$ interface psb_howmany_heap +!!$ function psb_howmany_int_heap(heap) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_int_heap +!!$ type(psb_int_heap), intent(in) :: heap +!!$ integer(psb_ipk_) :: psb_howmany_int_heap +!!$ end function psb_howmany_int_heap +!!$ function psb_howmany_sreal_idx_heap(heap) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_sreal_idx_heap +!!$ type(psb_sreal_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_) :: psb_howmany_sreal_idx_heap +!!$ end function psb_howmany_sreal_idx_heap +!!$ function psb_howmany_dreal_idx_heap(heap) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_dreal_idx_heap +!!$ type(psb_dreal_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_) :: psb_howmany_dreal_idx_heap +!!$ end function psb_howmany_dreal_idx_heap +!!$ function psb_howmany_int_idx_heap(heap) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_int_idx_heap +!!$ type(psb_int_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_) :: psb_howmany_int_idx_heap +!!$ end function psb_howmany_int_idx_heap +!!$ function psb_howmany_scomplex_idx_heap(heap) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_scomplex_idx_heap +!!$ type(psb_scomplex_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_) :: psb_howmany_scomplex_idx_heap +!!$ end function psb_howmany_scomplex_idx_heap +!!$ function psb_howmany_dcomplex_idx_heap(heap) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_dcomplex_idx_heap +!!$ type(psb_dcomplex_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_) :: psb_howmany_dcomplex_idx_heap +!!$ end function psb_howmany_dcomplex_idx_heap +!!$ end interface +!!$ +!!$ +!!$ interface psb_init_heap +!!$ subroutine psb_init_int_heap(heap,info,dir) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_int_heap +!!$ type(psb_int_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in), optional :: dir +!!$ end subroutine psb_init_int_heap +!!$ subroutine psb_init_sreal_idx_heap(heap,info,dir) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_sreal_idx_heap +!!$ type(psb_sreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in), optional :: dir +!!$ end subroutine psb_init_sreal_idx_heap +!!$ subroutine psb_init_int_idx_heap(heap,info,dir) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_int_idx_heap +!!$ type(psb_int_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in), optional :: dir +!!$ end subroutine psb_init_int_idx_heap +!!$ subroutine psb_init_scomplex_idx_heap(heap,info,dir) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_scomplex_idx_heap +!!$ type(psb_scomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in), optional :: dir +!!$ end subroutine psb_init_scomplex_idx_heap +!!$ subroutine psb_init_dcomplex_idx_heap(heap,info,dir) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_dcomplex_idx_heap +!!$ type(psb_dcomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in), optional :: dir +!!$ end subroutine psb_init_dcomplex_idx_heap +!!$ subroutine psb_init_dreal_idx_heap(heap,info,dir) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_dreal_idx_heap +!!$ type(psb_dreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in), optional :: dir +!!$ end subroutine psb_init_dreal_idx_heap +!!$ end interface +!!$ +!!$ +!!$ interface psb_dump_heap +!!$ subroutine psb_dump_int_heap(iout,heap,info) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_int_heap +!!$ type(psb_int_heap), intent(in) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in) :: iout +!!$ end subroutine psb_dump_int_heap +!!$ subroutine psb_dump_sreal_idx_heap(iout,heap,info) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_sreal_idx_heap +!!$ type(psb_sreal_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in) :: iout +!!$ end subroutine psb_dump_sreal_idx_heap +!!$ subroutine psb_dump_dreal_idx_heap(iout,heap,info) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_dreal_idx_heap +!!$ type(psb_dreal_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in) :: iout +!!$ end subroutine psb_dump_dreal_idx_heap +!!$ subroutine psb_dump_int_idx_heap(iout,heap,info) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_int_idx_heap +!!$ type(psb_int_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in) :: iout +!!$ end subroutine psb_dump_int_idx_heap +!!$ subroutine psb_dump_scomplex_idx_heap(iout,heap,info) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_scomplex_idx_heap +!!$ type(psb_scomplex_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in) :: iout +!!$ end subroutine psb_dump_scomplex_idx_heap +!!$ subroutine psb_dump_dcomplex_idx_heap(iout,heap,info) +!!$ import :: psb_ipk_, psb_spk_, psb_dpk_ +!!$ import :: psb_dcomplex_idx_heap +!!$ type(psb_dcomplex_idx_heap), intent(in) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in) :: iout +!!$ end subroutine psb_dump_dcomplex_idx_heap +!!$ end interface +!!$ +!!$ +!!$ interface psb_insert_heap +!!$ subroutine psb_insert_int_heap(key,heap,info) +!!$ import :: psb_int_heap, psb_ipk_ +!!$ integer(psb_ipk_), intent(in) :: key +!!$ type(psb_int_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_insert_int_heap +!!$ subroutine psb_insert_int_idx_heap(key,index,heap,info) +!!$ import :: psb_dpk_, psb_int_idx_heap, psb_ipk_ +!!$ integer(psb_ipk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index +!!$ type(psb_int_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_insert_int_idx_heap +!!$ subroutine psb_insert_sreal_idx_heap(key,index,heap,info) +!!$ import :: psb_spk_, psb_sreal_idx_heap, psb_ipk_ +!!$ real(psb_spk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index +!!$ type(psb_sreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_insert_sreal_idx_heap +!!$ subroutine psb_insert_dreal_idx_heap(key,index,heap,info) +!!$ import :: psb_dpk_, psb_dreal_idx_heap, psb_ipk_ +!!$ real(psb_dpk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index +!!$ type(psb_dreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_insert_dreal_idx_heap +!!$ subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) +!!$ import :: psb_spk_, psb_scomplex_idx_heap, psb_ipk_ +!!$ complex(psb_spk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index +!!$ type(psb_scomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_insert_scomplex_idx_heap +!!$ subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info) +!!$ import :: psb_dpk_, psb_dcomplex_idx_heap, psb_ipk_ +!!$ complex(psb_dpk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index +!!$ type(psb_dcomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_insert_dcomplex_idx_heap +!!$ end interface +!!$ +!!$ interface psb_heap_get_first +!!$ subroutine psb_int_heap_get_first(key,heap,info) +!!$ import :: psb_int_heap, psb_ipk_ +!!$ type(psb_int_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: key,info +!!$ end subroutine psb_int_heap_get_first +!!$ subroutine psb_int_idx_heap_get_first(key,index,heap,info) +!!$ import :: psb_int_idx_heap, psb_ipk_ +!!$ type(psb_int_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ integer(psb_ipk_), intent(out) :: key +!!$ end subroutine psb_int_idx_heap_get_first +!!$ subroutine psb_sreal_idx_heap_get_first(key,index,heap,info) +!!$ import :: psb_spk_, psb_sreal_idx_heap, psb_ipk_ +!!$ type(psb_sreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ real(psb_spk_), intent(out) :: key +!!$ end subroutine psb_sreal_idx_heap_get_first +!!$ subroutine psb_dreal_idx_heap_get_first(key,index,heap,info) +!!$ import :: psb_dpk_, psb_dreal_idx_heap, psb_ipk_ +!!$ type(psb_dreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ real(psb_dpk_), intent(out) :: key +!!$ end subroutine psb_dreal_idx_heap_get_first +!!$ subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info) +!!$ import :: psb_spk_, psb_scomplex_idx_heap, psb_ipk_ +!!$ type(psb_scomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ complex(psb_spk_), intent(out) :: key +!!$ end subroutine psb_scomplex_idx_heap_get_first +!!$ +!!$ subroutine psb_dcomplex_idx_heap_get_first(key,index,heap,info) +!!$ import :: psb_dpk_, psb_dcomplex_idx_heap, psb_ipk_ +!!$ type(psb_dcomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ complex(psb_dpk_), intent(out) :: key +!!$ end subroutine psb_dcomplex_idx_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_int_heap(key,last,heap,dir,info) +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ +!!$ ! +!!$ ! Input: +!!$ ! key: the new value +!!$ ! last: pointer to the last occupied element in heap +!!$ ! heap: the heap +!!$ ! dir: sorting direction +!!$ +!!$ integer(psb_ipk_), intent(in) :: key,dir +!!$ integer(psb_ipk_), intent(inout) :: heap(:),last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_int_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_int_heap_get_first(key,last,heap,dir,info) +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ +!!$ integer(psb_ipk_), intent(inout) :: key,last +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ integer(psb_ipk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_int_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_real_heap(key,last,heap,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ real(psb_spk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ real(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_real_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_real_heap_get_first(key,last,heap,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ real(psb_spk_), intent(inout) :: key +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ real(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_real_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_double_heap(key,last,heap,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ real(psb_dpk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ real(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_double_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_double_heap_get_first(key,last,heap,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ real(psb_dpk_), intent(inout) :: key +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ real(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_double_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_scomplex_heap(key,last,heap,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ complex(psb_spk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ complex(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_scomplex_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ complex(psb_spk_), intent(inout) :: key +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ complex(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_scomplex_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ complex(psb_dpk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ complex(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_dcomplex_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_dcomplex_heap_get_first(key,last,heap,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ complex(psb_dpk_), intent(inout) :: key +!!$ integer(psb_ipk_), intent(inout) :: last +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ complex(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_dcomplex_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_int_idx_heap(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_ipk_ +!!$ integer(psb_ipk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index,dir +!!$ integer(psb_ipk_), intent(inout) :: heap(:),last +!!$ integer(psb_ipk_), intent(inout) :: idxs(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_int_idx_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_int_idx_heap_get_first(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_ipk_ +!!$ integer(psb_ipk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ integer(psb_ipk_), intent(inout) :: last,idxs(:) +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ integer(psb_ipk_), intent(out) :: key +!!$ end subroutine psi_int_idx_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_sreal_idx_heap(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ real(psb_spk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index,dir +!!$ real(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: idxs(:),last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_sreal_idx_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_sreal_idx_heap_get_first(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ real(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ integer(psb_ipk_), intent(inout) :: last,idxs(:) +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ real(psb_spk_), intent(out) :: key +!!$ end subroutine psi_sreal_idx_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_dreal_idx_heap(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ real(psb_dpk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index,dir +!!$ real(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: idxs(:),last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_dreal_idx_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_dreal_idx_heap_get_first(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ real(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ integer(psb_ipk_), intent(inout) :: last,idxs(:) +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ real(psb_dpk_), intent(out) :: key +!!$ end subroutine psi_dreal_idx_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ complex(psb_spk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index,dir +!!$ complex(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: idxs(:),last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_scomplex_idx_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_spk_, psb_ipk_ +!!$ complex(psb_spk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ integer(psb_ipk_), intent(inout) :: last,idxs(:) +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ complex(psb_spk_), intent(out) :: key +!!$ end subroutine psi_scomplex_idx_heap_get_first +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ complex(psb_dpk_), intent(in) :: key +!!$ integer(psb_ipk_), intent(in) :: index,dir +!!$ complex(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(inout) :: idxs(:),last +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psi_insert_dcomplex_idx_heap +!!$ end interface +!!$ +!!$ interface +!!$ subroutine psi_dcomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) +!!$ import :: psb_dpk_, psb_ipk_ +!!$ complex(psb_dpk_), intent(inout) :: heap(:) +!!$ integer(psb_ipk_), intent(out) :: index,info +!!$ integer(psb_ipk_), intent(inout) :: last,idxs(:) +!!$ integer(psb_ipk_), intent(in) :: dir +!!$ complex(psb_dpk_), intent(out) :: key +!!$ end subroutine psi_dcomplex_idx_heap_get_first +!!$ end interface +!!$ +!!$ +!!$ interface psb_free_heap +!!$ module procedure psb_free_int_heap, psb_free_int_idx_heap,& +!!$ & psb_free_sreal_idx_heap, psb_free_scomplex_idx_heap, & +!!$ & psb_free_dreal_idx_heap, psb_free_dcomplex_idx_heap +!!$ end interface +!!$ +!!$contains +!!$ +!!$ subroutine psb_free_int_heap(heap,info) +!!$ implicit none +!!$ type(psb_int_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ info=psb_success_ +!!$ if (allocated(heap%keys)) deallocate(heap%keys,stat=info) +!!$ +!!$ end subroutine psb_free_int_heap +!!$ +!!$ subroutine psb_free_sreal_idx_heap(heap,info) +!!$ implicit none +!!$ type(psb_sreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ info=psb_success_ +!!$ if (allocated(heap%keys)) deallocate(heap%keys,stat=info) +!!$ if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) +!!$ +!!$ end subroutine psb_free_sreal_idx_heap +!!$ +!!$ subroutine psb_free_dreal_idx_heap(heap,info) +!!$ implicit none +!!$ type(psb_dreal_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ info=psb_success_ +!!$ if (allocated(heap%keys)) deallocate(heap%keys,stat=info) +!!$ if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) +!!$ +!!$ end subroutine psb_free_dreal_idx_heap +!!$ +!!$ subroutine psb_free_int_idx_heap(heap,info) +!!$ implicit none +!!$ type(psb_int_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ info=psb_success_ +!!$ if (allocated(heap%keys)) deallocate(heap%keys,stat=info) +!!$ if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) +!!$ +!!$ end subroutine psb_free_int_idx_heap +!!$ +!!$ subroutine psb_free_scomplex_idx_heap(heap,info) +!!$ implicit none +!!$ type(psb_scomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ info=psb_success_ +!!$ if (allocated(heap%keys)) deallocate(heap%keys,stat=info) +!!$ if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) +!!$ +!!$ end subroutine psb_free_scomplex_idx_heap +!!$ +!!$ subroutine psb_free_dcomplex_idx_heap(heap,info) +!!$ implicit none +!!$ type(psb_dcomplex_idx_heap), intent(inout) :: heap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ +!!$ info=psb_success_ +!!$ if (allocated(heap%keys)) deallocate(heap%keys,stat=info) +!!$ if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info) +!!$ +!!$ end subroutine psb_free_dcomplex_idx_heap +!!$ end module psb_sort_mod diff --git a/base/modules/psb_z_sort_mod.f90 b/base/modules/psb_z_sort_mod.f90 index 72281eca..b944bd40 100644 --- a/base/modules/psb_z_sort_mod.f90 +++ b/base/modules/psb_z_sort_mod.f90 @@ -79,6 +79,54 @@ module psb_z_sort_mod end subroutine psb_zmsort end interface psb_msort + interface + subroutine psi_z_lmsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_lmsort_up + subroutine psi_z_lmsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_lmsort_dw + subroutine psi_z_almsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_almsort_up + subroutine psi_z_almsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_almsort_dw + end interface + interface + subroutine psi_z_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_amsort_up + subroutine psi_z_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_amsort_dw + end interface + + interface psb_qsort subroutine psb_zqsort(x,ix,dir,flag) import diff --git a/base/serial/Makefile b/base/serial/Makefile index 7184dc4a..50057b5b 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -1,7 +1,7 @@ include ../../Make.inc -FOBJS = psb_lsame.o psi_serial_impl.o psb_sort_impl.o \ +FOBJS = psb_lsame.o psi_serial_impl.o \ psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o \ psb_sspspmm.o psb_dspspmm.o psb_cspspmm.o psb_zspspmm.o \ psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \ @@ -11,13 +11,14 @@ FOBJS = psb_lsame.o psi_serial_impl.o psb_sort_impl.o \ psb_sgelp.o psb_dgelp.o psb_cgelp.o psb_zgelp.o \ psb_samax_s.o psb_damax_s.o psb_camax_s.o psb_zamax_s.o \ psb_sasum_s.o psb_dasum_s.o psb_casum_s.o psb_zasum_s.o +# psb_sort_impl.o LIBDIR=.. INCDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) -lib: auxd f77d impld lib1 $(FOBJS) +lib: auxd f77d impld sortd lib1 $(FOBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(FOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) @@ -34,10 +35,14 @@ f77d: impld: cd impl && $(MAKE) lib +sortd: + cd sort && $(MAKE) lib + clean: /bin/rm -f $(FOBJS) *$(.mod) (cd aux; $(MAKE) clean) (cd f77; $(MAKE) clean) (cd impl; $(MAKE) clean) + (cd sort; $(MAKE) clean) veryclean: clean diff --git a/base/serial/aux/Makefile b/base/serial/aux/Makefile index 80f8e407..19ed221e 100644 --- a/base/serial/aux/Makefile +++ b/base/serial/aux/Makefile @@ -3,18 +3,19 @@ include ../../../Make.inc # The object files # -FOBJS = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\ - imsr.o imsrx.o imsru.o iamsort_up.o iamsort_dw.o idot.o inrm2.o\ - dsr.o dsrx.o dasr.o dasrx.o dmsr.o dmsrx.o \ - dmsort_up.o dmsort_dw.o damsort_up.o damsort_dw.o \ - ssr.o ssrx.o sasr.o sasrx.o smsr.o smsrx.o \ - smsort_up.o smsort_dw.o samsort_up.o samsort_dw.o \ - clcmp_mod.o clsr.o clsrx.o \ - calcmp_mod.o calsr.o calsrx.o \ - cacmp_mod.o casr.o casrx.o camsr.o camsrx.o camsort_up.o camsort_dw.o\ - zlcmp_mod.o zlsr.o zlsrx.o \ - zalcmp_mod.o zalsr.o zalsrx.o \ - zacmp_mod.o zasr.o zasrx.o zamsr.o zamsrx.o zamsort_up.o zamsort_dw.o +FOBJS = idot.o inrm2.o +# FOBJS = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\ +# imsr.o imsrx.o imsru.o iamsort_up.o iamsort_dw.o idot.o inrm2.o\ +# dsr.o dsrx.o dasr.o dasrx.o dmsr.o dmsrx.o \ +# dmsort_up.o dmsort_dw.o damsort_up.o damsort_dw.o \ +# ssr.o ssrx.o sasr.o sasrx.o smsr.o smsrx.o \ +# smsort_up.o smsort_dw.o samsort_up.o samsort_dw.o \ +# clcmp_mod.o clsr.o clsrx.o \ +# calcmp_mod.o calsr.o calsrx.o \ +# cacmp_mod.o casr.o casrx.o camsr.o camsrx.o camsort_up.o camsort_dw.o\ +# zlcmp_mod.o zlsr.o zlsrx.o \ +# zalcmp_mod.o zalsr.o zalsrx.o \ +# zacmp_mod.o zasr.o zasrx.o zamsr.o zamsrx.o zamsort_up.o zamsort_dw.o OBJS=$(FOBJS) diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index 7a74a6b1..805c79f8 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -3382,7 +3382,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ja(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3493,7 +3493,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,jas(i:imx),ix2,iret) + call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3586,7 +3586,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3598,7 +3598,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3704,7 +3704,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ia(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3813,7 +3813,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ias(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3900,7 +3900,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3911,7 +3911,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index f3ffc277..f9a72051 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -2846,7 +2846,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:) complex(psb_spk_), allocatable :: col(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze complex(psb_spk_) :: cfb diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index 04767b94..c24be8b1 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -3085,7 +3085,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: irow(:), idxs(:) complex(psb_spk_), allocatable :: row(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze complex(psb_spk_) :: cfb diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 2c02bfda..a69bf6e9 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -3382,7 +3382,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ja(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3493,7 +3493,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,jas(i:imx),ix2,iret) + call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3586,7 +3586,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3598,7 +3598,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3704,7 +3704,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ia(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3813,7 +3813,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ias(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3900,7 +3900,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3911,7 +3911,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index ffec6062..60550c53 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -2846,7 +2846,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:) real(psb_dpk_), allocatable :: col(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze real(psb_dpk_) :: cfb diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index 67f0ab91..70503837 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -3085,7 +3085,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: irow(:), idxs(:) real(psb_dpk_), allocatable :: row(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze real(psb_dpk_) :: cfb diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index c94e192a..3be5e21c 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -3382,7 +3382,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ja(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3493,7 +3493,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,jas(i:imx),ix2,iret) + call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3586,7 +3586,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3598,7 +3598,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3704,7 +3704,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ia(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3813,7 +3813,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ias(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3900,7 +3900,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3911,7 +3911,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index f38ce7af..74709e7d 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -2846,7 +2846,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:) real(psb_spk_), allocatable :: col(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze real(psb_spk_) :: cfb diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index 0725bba6..25f76246 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -3085,7 +3085,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: irow(:), idxs(:) real(psb_spk_), allocatable :: row(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze real(psb_spk_) :: cfb diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index fdc32e5d..8c22a300 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -3382,7 +3382,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ja(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3493,7 +3493,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,jas(i:imx),ix2,iret) + call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3586,7 +3586,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3598,7 +3598,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3704,7 +3704,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ia(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3813,7 +3813,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call msort_up(nzl,ias(i:imx),ix2,iret) + call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3900,7 +3900,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3911,7 +3911,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index b1928904..b12a9e21 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -2846,7 +2846,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:) complex(psb_dpk_), allocatable :: col(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze complex(psb_dpk_) :: cfb diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index 218833d6..88fc1552 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -3085,7 +3085,6 @@ contains integer(psb_ipk_) :: ma,na,mb,nb integer(psb_ipk_), allocatable :: irow(:), idxs(:) complex(psb_dpk_), allocatable :: row(:) - type(psb_int_heap) :: heap integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, & & nzc,nnzre, isz, ipb, irwsz, nrc, nze complex(psb_dpk_) :: cfb diff --git a/base/serial/sort/Makefile b/base/serial/sort/Makefile index e4449f5b..c44b1e1f 100644 --- a/base/serial/sort/Makefile +++ b/base/serial/sort/Makefile @@ -4,12 +4,13 @@ include ../../../Make.inc # The object files # BOBJS=psi_lcx_mod.o psi_alcx_mod.o psi_acx_mod.o +IOBJS=psb_i_hsort_impl.o psb_i_isort_impl.o psb_i_msort_impl.o psb_i_qsort_impl.o SOBJS=psb_s_hsort_impl.o psb_s_isort_impl.o psb_s_msort_impl.o psb_s_qsort_impl.o DOBJS=psb_d_hsort_impl.o psb_d_isort_impl.o psb_d_msort_impl.o psb_d_qsort_impl.o COBJS=psb_c_hsort_impl.o psb_c_isort_impl.o psb_c_msort_impl.o psb_c_qsort_impl.o ZOBJS=psb_z_hsort_impl.o psb_z_isort_impl.o psb_z_msort_impl.o psb_z_qsort_impl.o -OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) +OBJS=$(BOBJS) $(IOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) # # Where the library should go, and how it is called. diff --git a/base/serial/sort/psb_c_hsort_impl.f90 b/base/serial/sort/psb_c_hsort_impl.f90 index 3fe985e8..d2cc5424 100644 --- a/base/serial/sort/psb_c_hsort_impl.f90 +++ b/base/serial/sort/psb_c_hsort_impl.f90 @@ -50,7 +50,7 @@ subroutine psb_chsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(inout) :: ix(:) integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info - real(psb_spk_) :: key + complex(psb_spk_) :: key integer(psb_ipk_) :: index integer(psb_ipk_) :: ierr(5) @@ -391,7 +391,7 @@ contains 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 + use psb_c_sort_mod, psb_protect_name => psi_c_heap_get_first implicit none ! @@ -633,7 +633,7 @@ contains 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 + use psb_c_sort_mod, psb_protect_name => psi_c_idx_insert_heap implicit none ! @@ -869,7 +869,7 @@ 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 + use psb_c_sort_mod, psb_protect_name => psi_c_idx_heap_get_first implicit none ! @@ -905,22 +905,22 @@ subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info) info = -4 case (psb_asort_up_) - call fix_aup(last,heap) + call fix_aup(last,heap,idxs) case (psb_asort_down_) - call fix_adw(last,heap) + call fix_adw(last,heap,idxs) case (psb_alsort_up_) - call fix_alup(last,heap) + call fix_alup(last,heap,idxs) case (psb_alsort_down_) - call fix_aldw(last,heap) + call fix_aldw(last,heap,idxs) case (psb_lsort_up_) - call fix_lup(last,heap) + call fix_lup(last,heap,idxs) case (psb_lsort_down_) - call fix_ldw(last,heap) + call fix_ldw(last,heap,idxs) case default write(psb_err_unit,*) 'Invalid direction in heap ',dir @@ -933,7 +933,7 @@ contains use psi_acx_mod integer(psb_ipk_), intent(in) :: last complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_spk_) :: temp @@ -968,7 +968,7 @@ contains use psi_acx_mod integer(psb_ipk_), intent(in) :: last complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_spk_) :: temp @@ -1002,7 +1002,7 @@ contains use psi_lcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_spk_) :: temp @@ -1036,7 +1036,7 @@ contains use psi_lcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_spk_) :: temp @@ -1070,7 +1070,7 @@ contains use psi_alcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_spk_) :: temp @@ -1104,7 +1104,7 @@ contains use psi_alcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_spk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_spk_) :: temp @@ -1134,7 +1134,7 @@ contains end subroutine fix_aldw -end subroutine psi_c_heap_get_first +end subroutine psi_c_idx_heap_get_first diff --git a/base/serial/sort/psb_c_isort_impl.f90 b/base/serial/sort/psb_c_isort_impl.f90 index 16109736..aad1e69a 100644 --- a/base/serial/sort/psb_c_isort_impl.f90 +++ b/base/serial/sort/psb_c_isort_impl.f90 @@ -137,13 +137,13 @@ subroutine psb_cisort(x,ix,dir,flag) return end subroutine psb_cisort -subroutine psi_clisrx_up(n,x,ix) +subroutine psi_clisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_spk_) :: xx @@ -167,13 +167,13 @@ subroutine psi_clisrx_up(n,x,ix) end subroutine psi_clisrx_up -subroutine psi_clisrx_dw(n,x,ix) +subroutine psi_clisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_spk_) :: xx @@ -246,13 +246,13 @@ subroutine psi_clisr_dw(n,x) enddo end subroutine psi_clisr_dw -subroutine psi_calisrx_up(n,x,ix) +subroutine psi_calisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_spk_) :: xx @@ -275,13 +275,13 @@ subroutine psi_calisrx_up(n,x,ix) enddo end subroutine psi_calisrx_up -subroutine psi_calisrx_dw(n,x,ix) +subroutine psi_calisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_spk_) :: xx @@ -354,12 +354,12 @@ subroutine psi_calisr_dw(n,x) enddo end subroutine psi_calisr_dw -subroutine psi_caisrx_up(n,x,ix) +subroutine psi_caisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_spk_) :: xx @@ -382,12 +382,12 @@ subroutine psi_caisrx_up(n,x,ix) enddo end subroutine psi_caisrx_up -subroutine psi_caisrx_dw(n,x,ix) +subroutine psi_caisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_spk_) :: xx diff --git a/base/serial/sort/psb_c_msort_impl.f90 b/base/serial/sort/psb_c_msort_impl.f90 index f339739f..ada78c5b 100644 --- a/base/serial/sort/psb_c_msort_impl.f90 +++ b/base/serial/sort/psb_c_msort_impl.f90 @@ -29,127 +29,128 @@ !!$ 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 -! - - + ! + ! 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 + 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(:) - name='psb_cmsort' - call psb_erractionsave(err_act) + integer(psb_ipk_) :: dir_, flag_, n, 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 + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - n = size(x) + name='psb_cmsort' + call psb_erractionsave(err_act) - 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_ + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) + 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) = 4; ierr(2) = flag_; + 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 - - 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) + + 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 - end if - - return + + 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(dir_) + case (psb_lsort_up_) + call psi_c_lmsort_up(n,x,iaux,iret) + case (psb_lsort_down_) + call psi_c_lmsort_dw(n,x,iaux,iret) + case (psb_alsort_up_) + call psi_c_almsort_up(n,x,iaux,iret) + case (psb_alsort_down_) + call psi_c_almsort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_c_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_c_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,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + end if + + return 9999 call psb_error_handler(err_act) - return + return + -contains + end subroutine psb_cmsort - subroutine in_lmsort_up(n,k,l,iret) + subroutine psi_c_lmsort_up(n,k,l,iret) use psb_const_mod use psi_lcx_mod implicit none @@ -252,9 +253,9 @@ contains end do outer end do mergepass - end subroutine in_lmsort_up + end subroutine psi_c_lmsort_up - subroutine in_lmsort_dw(n,k,l,iret) + subroutine psi_c_lmsort_dw(n,k,l,iret) use psb_const_mod use psi_lcx_mod implicit none @@ -357,9 +358,9 @@ contains end do outer end do mergepass - end subroutine in_lmsort_dw + end subroutine psi_c_lmsort_dw - subroutine in_amsort_up(n,k,l,iret) + subroutine psi_c_amsort_up(n,k,l,iret) use psb_const_mod use psi_acx_mod implicit none @@ -462,9 +463,9 @@ contains end do outer end do mergepass - end subroutine in_amsort_up + end subroutine psi_c_amsort_up - subroutine in_amsort_dw(n,k,l,iret) + subroutine psi_c_amsort_dw(n,k,l,iret) use psb_const_mod use psi_acx_mod implicit none @@ -567,9 +568,9 @@ contains end do outer end do mergepass - end subroutine in_amsort_dw + end subroutine psi_c_amsort_dw - subroutine in_almsort_up(n,k,l,iret) + subroutine psi_c_almsort_up(n,k,l,iret) use psb_const_mod use psi_alcx_mod implicit none @@ -672,9 +673,9 @@ contains end do outer end do mergepass - end subroutine in_almsort_up + end subroutine psi_c_almsort_up - subroutine in_almsort_dw(n,k,l,iret) + subroutine psi_c_almsort_dw(n,k,l,iret) use psb_const_mod use psi_alcx_mod implicit none @@ -777,6 +778,5 @@ contains end do outer end do mergepass - end subroutine in_almsort_dw + end subroutine psi_c_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 index e6a2138a..cf5b7b0e 100644 --- a/base/serial/sort/psb_c_qsort_impl.f90 +++ b/base/serial/sort/psb_c_qsort_impl.f90 @@ -48,7 +48,7 @@ subroutine psb_cqsort(x,ix,dir,flag) 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_) :: dir_, flag_, n, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -138,607 +138,14 @@ subroutine psb_cqsort(x,ix,dir,flag) 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) +subroutine psi_clqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt @@ -771,40 +178,40 @@ subroutine psi_clqsrx_up(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -829,11 +236,11 @@ subroutine psi_clqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -855,14 +262,14 @@ subroutine psi_clqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_clisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_clisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_clisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -870,31 +277,31 @@ subroutine psi_clqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_clisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_clisrx_up(n2,x(i:iux),idx(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)) + call psi_clisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_clisrx_up(n,x,indx) + call psi_clisrx_up(n,x,idx) endif end subroutine psi_clqsrx_up -subroutine psi_clqsrx_dw(n,x,ix) +subroutine psi_clqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt @@ -927,40 +334,40 @@ subroutine psi_clqsrx_dw(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -985,11 +392,11 @@ subroutine psi_clqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -1011,14 +418,14 @@ subroutine psi_clqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_clisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_clisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_clisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1026,19 +433,19 @@ subroutine psi_clqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_clisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_clisrx_dw(n2,x(i:iux),idx(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)) + call psi_clisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_clisrx_dw(n,x,indx) + call psi_clisrx_dw(n,x,idx) endif end subroutine psi_clqsrx_dw @@ -1193,7 +600,7 @@ subroutine psi_clqsr_dw(n,x) complex(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(@FKIND) :: piv, xt, xk + complex(psb_spk_) :: piv, xt, xk integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: n1, n2 @@ -1325,14 +732,14 @@ subroutine psi_clqsr_dw(n,x) end subroutine psi_clqsr_dw -subroutine psi_calqsrx_up(n,x,ix) +subroutine psi_calqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt @@ -1365,40 +772,40 @@ subroutine psi_calqsrx_up(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -1423,11 +830,11 @@ subroutine psi_calqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -1449,14 +856,14 @@ subroutine psi_calqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_calisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_calisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_calisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1464,30 +871,30 @@ subroutine psi_calqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_calisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_calisrx_up(n2,x(i:iux),idx(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)) + call psi_calisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_calisrx_up(n,x,indx) + call psi_calisrx_up(n,x,idx) endif end subroutine psi_calqsrx_up -subroutine psi_calqsrx_dw(n,x,ix) +subroutine psi_calqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt @@ -1520,40 +927,40 @@ subroutine psi_calqsrx_dw(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -1578,11 +985,11 @@ subroutine psi_calqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -1604,14 +1011,14 @@ subroutine psi_calqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_calisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_calisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_calisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1619,19 +1026,19 @@ subroutine psi_calqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_calisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_calisrx_dw(n2,x(i:iux),idx(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)) + call psi_calisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_calisrx_dw(n,x,indx) + call psi_calisrx_dw(n,x,idx) endif end subroutine psi_calqsrx_dw @@ -1785,7 +1192,7 @@ subroutine psi_calqsr_dw(n,x) complex(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(@FKIND) :: piv, xt, xk + complex(psb_spk_) :: piv, xt, xk integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: n1, n2 @@ -1916,16 +1323,17 @@ subroutine psi_calqsr_dw(n,x) endif end subroutine psi_calqsr_dw -subroutine psi_caqsrx_up(n,x,ix) +subroutine psi_caqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -1955,39 +1363,39 @@ subroutine psi_caqsrx_up(n,x,ix) piv = abs(x(lpiv)) if (piv < abs(x(i))) then xt = x(i) - ixt = indx(i) + ixt = idx(i) x(i) = x(lpiv) - indx(i) = indx(lpiv) + idx(i) = idx(lpiv) x(lpiv) = xt - indx(lpiv) = ixt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -2012,11 +1420,11 @@ subroutine psi_caqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -2038,14 +1446,14 @@ subroutine psi_caqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_caisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_caisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_caisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -2053,34 +1461,35 @@ subroutine psi_caqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_caisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_caisrx_up(n2,x(i:iux),idx(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)) + call psi_caisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_caisrx_up(n,x,indx) + call psi_caisrx_up(n,x,idx) endif end subroutine psi_caqsrx_up -subroutine psi_caqsrx_dw(n,x,ix) +subroutine psi_caqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -2109,39 +1518,39 @@ subroutine psi_caqsrx_dw(n,x,ix) 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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -2166,11 +1575,11 @@ subroutine psi_caqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -2192,14 +1601,14 @@ subroutine psi_caqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_caisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_caisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_caisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -2207,19 +1616,19 @@ subroutine psi_caqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_caisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_caisrx_dw(n2,x(i:iux),idx(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)) + call psi_caisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_caisrx_dw(n,x,indx) + call psi_caisrx_dw(n,x,idx) endif end subroutine psi_caqsrx_dw @@ -2232,7 +1641,8 @@ subroutine psi_caqsr_up(n,x) complex(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -2371,7 +1781,8 @@ subroutine psi_caqsr_dw(n,x) complex(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 diff --git a/base/serial/sort/psb_d_hsort_impl.f90 b/base/serial/sort/psb_d_hsort_impl.f90 index d8d0ac0e..bab0d5ab 100644 --- a/base/serial/sort/psb_d_hsort_impl.f90 +++ b/base/serial/sort/psb_d_hsort_impl.f90 @@ -50,7 +50,7 @@ subroutine psb_dhsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(inout) :: ix(:) integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info - real(psb_spk_) :: key + real(psb_dpk_) :: key integer(psb_ipk_) :: index integer(psb_ipk_) :: ierr(5) diff --git a/base/serial/sort/psb_d_isort_impl.f90 b/base/serial/sort/psb_d_isort_impl.f90 index 86593c27..1df05393 100644 --- a/base/serial/sort/psb_d_isort_impl.f90 +++ b/base/serial/sort/psb_d_isort_impl.f90 @@ -129,12 +129,12 @@ subroutine psb_disort(x,ix,dir,flag) return end subroutine psb_disort -subroutine psi_disrx_up(n,x,ix) +subroutine psi_disrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_dpk_) :: xx @@ -157,12 +157,12 @@ subroutine psi_disrx_up(n,x,ix) enddo end subroutine psi_disrx_up -subroutine psi_disrx_dw(n,x,ix) +subroutine psi_disrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_dpk_) :: xx @@ -234,12 +234,12 @@ subroutine psi_disr_dw(n,x) enddo end subroutine psi_disr_dw -subroutine psi_daisrx_up(n,x,ix) +subroutine psi_daisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_dpk_) :: xx @@ -262,12 +262,12 @@ subroutine psi_daisrx_up(n,x,ix) enddo end subroutine psi_daisrx_up -subroutine psi_daisrx_dw(n,x,ix) +subroutine psi_daisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_dpk_) :: xx diff --git a/base/serial/sort/psb_d_msort_impl.f90 b/base/serial/sort/psb_d_msort_impl.f90 index 9cb40ab2..69bf6ee7 100644 --- a/base/serial/sort/psb_d_msort_impl.f90 +++ b/base/serial/sort/psb_d_msort_impl.f90 @@ -29,117 +29,118 @@ !!$ 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_ + ! + ! 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(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) ! OK keep going case default - ierr(1) = 4; ierr(2) = flag_; + 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 - - 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) + 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 - end if - - - return + + 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(dir_) + case (psb_sort_up_) + call psi_d_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_d_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_d_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_d_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,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + end if + + + return 9999 call psb_error_handler(err_act) - return + return + -contains + end subroutine psb_dmsort - subroutine in_msort_up(n,k,l,iret) + subroutine psi_d_msort_up(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -241,9 +242,9 @@ contains end do outer end do mergepass - end subroutine in_msort_up + end subroutine psi_d_msort_up - subroutine in_msort_dw(n,k,l,iret) + subroutine psi_d_msort_dw(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -345,9 +346,9 @@ contains end do outer end do mergepass - end subroutine in_msort_dw + end subroutine psi_d_msort_dw - subroutine in_amsort_up(n,k,l,iret) + subroutine psi_d_amsort_up(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -449,9 +450,9 @@ contains end do outer end do mergepass - end subroutine in_amsort_up + end subroutine psi_d_amsort_up - subroutine in_amsort_dw(n,k,l,iret) + subroutine psi_d_amsort_dw(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -553,10 +554,8 @@ contains end do outer end do mergepass - end subroutine in_amsort_dw - + end subroutine psi_d_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 index d6291ebc..c0eda8ed 100644 --- a/base/serial/sort/psb_d_qsort_impl.f90 +++ b/base/serial/sort/psb_d_qsort_impl.f90 @@ -48,7 +48,7 @@ subroutine psb_dqsort(x,ix,dir,flag) 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_) :: dir_, flag_, n, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -129,15 +129,13 @@ subroutine psb_dqsort(x,ix,dir,flag) return end subroutine psb_dqsort - - -subroutine psi_dqsrx_up(n,x,ix) +subroutine psi_dqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. real(psb_dpk_) :: piv, xk, xt @@ -170,40 +168,40 @@ subroutine psi_dqsrx_up(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -228,11 +226,11 @@ subroutine psi_dqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -254,14 +252,14 @@ subroutine psi_dqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_disrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_disrx_up(n1,x(ilx:i-1),idx(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)) + call psi_disrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -269,29 +267,29 @@ subroutine psi_dqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_disrx_up(n2,x(i:iux),indx(i:iux)) + call psi_disrx_up(n2,x(i:iux),idx(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)) + call psi_disrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_disrx_up(n,x,indx) + call psi_disrx_up(n,x,idx) endif end subroutine psi_dqsrx_up -subroutine psi_dqsrx_dw(n,x,ix) +subroutine psi_dqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. real(psb_dpk_) :: piv, xk, xt @@ -324,40 +322,40 @@ subroutine psi_dqsrx_dw(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -382,11 +380,11 @@ subroutine psi_dqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -408,14 +406,14 @@ subroutine psi_dqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_disrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_disrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_disrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -423,19 +421,19 @@ subroutine psi_dqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_disrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_disrx_dw(n2,x(i:iux),idx(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)) + call psi_disrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_disrx_dw(n,x,indx) + call psi_disrx_dw(n,x,idx) endif end subroutine psi_dqsrx_dw @@ -590,7 +588,7 @@ subroutine psi_dqsr_dw(n,x) integer(psb_ipk_), intent(in) :: n ! .. ! .. Local Scalars .. - real(@FKIND) :: piv, xt, xk + real(psb_dpk_) :: piv, xt, xk integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: n1, n2 @@ -722,16 +720,17 @@ subroutine psi_dqsr_dw(n,x) end subroutine psi_dqsr_dw -subroutine psi_daqsrx_up(n,x,ix) +subroutine psi_daqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -761,39 +760,39 @@ subroutine psi_daqsrx_up(n,x,ix) piv = abs(x(lpiv)) if (piv < abs(x(i))) then xt = x(i) - ixt = indx(i) + ixt = idx(i) x(i) = x(lpiv) - indx(i) = indx(lpiv) + idx(i) = idx(lpiv) x(lpiv) = xt - indx(lpiv) = ixt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -818,11 +817,11 @@ subroutine psi_daqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -844,14 +843,14 @@ subroutine psi_daqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_daisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_daisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_daisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -859,34 +858,35 @@ subroutine psi_daqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_daisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_daisrx_up(n2,x(i:iux),idx(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)) + call psi_daisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_daisrx_up(n,x,indx) + call psi_daisrx_up(n,x,idx) endif end subroutine psi_daqsrx_up -subroutine psi_daqsrx_dw(n,x,ix) +subroutine psi_daqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -915,39 +915,39 @@ subroutine psi_daqsrx_dw(n,x,ix) 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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -972,11 +972,11 @@ subroutine psi_daqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -998,14 +998,14 @@ subroutine psi_daqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_daisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_daisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_daisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1013,19 +1013,19 @@ subroutine psi_daqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_daisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_daisrx_dw(n2,x(i:iux),idx(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)) + call psi_daisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_daisrx_dw(n,x,indx) + call psi_daisrx_dw(n,x,idx) endif end subroutine psi_daqsrx_dw @@ -1038,7 +1038,8 @@ subroutine psi_daqsr_up(n,x) real(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -1177,7 +1178,8 @@ subroutine psi_daqsr_dw(n,x) real(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 diff --git a/base/serial/sort/psb_i_hsort_impl.f90 b/base/serial/sort/psb_i_hsort_impl.f90 index 85dc0b10..8cff29a6 100644 --- a/base/serial/sort/psb_i_hsort_impl.f90 +++ b/base/serial/sort/psb_i_hsort_impl.f90 @@ -50,7 +50,7 @@ subroutine psb_ihsort(x,ix,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_) :: key integer(psb_ipk_) :: index integer(psb_ipk_) :: ierr(5) diff --git a/base/serial/sort/psb_i_isort_impl.f90 b/base/serial/sort/psb_i_isort_impl.f90 index c122be02..cdd34688 100644 --- a/base/serial/sort/psb_i_isort_impl.f90 +++ b/base/serial/sort/psb_i_isort_impl.f90 @@ -129,12 +129,12 @@ subroutine psb_iisort(x,ix,dir,flag) return end subroutine psb_iisort -subroutine psi_iisrx_up(n,x,ix) +subroutine psi_iisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: xx @@ -157,12 +157,12 @@ subroutine psi_iisrx_up(n,x,ix) enddo end subroutine psi_iisrx_up -subroutine psi_iisrx_dw(n,x,ix) +subroutine psi_iisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: xx @@ -234,12 +234,12 @@ subroutine psi_iisr_dw(n,x) enddo end subroutine psi_iisr_dw -subroutine psi_iaisrx_up(n,x,ix) +subroutine psi_iaisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: xx @@ -262,12 +262,12 @@ subroutine psi_iaisrx_up(n,x,ix) enddo end subroutine psi_iaisrx_up -subroutine psi_iaisrx_dw(n,x,ix) +subroutine psi_iaisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: xx diff --git a/base/serial/sort/psb_i_msort_impl.f90 b/base/serial/sort/psb_i_msort_impl.f90 index 59cdf0f8..55792e85 100644 --- a/base/serial/sort/psb_i_msort_impl.f90 +++ b/base/serial/sort/psb_i_msort_impl.f90 @@ -29,308 +29,309 @@ !!$ 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 - + ! 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 ! - ! 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 + 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. - goto 9999 + return endif - end if - enddo + 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 + 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 <= ub) + + do while (lb.le.ub) m = (lb+ub)/2 - if (key==v(m)) then + if (key.eq.v(m)) then ipos = m - return + lb = ub + 1 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 + 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 - 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 + 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=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_ + 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(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) ! OK keep going case default - ierr(1) = 4; ierr(2) = flag_; + 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 - - 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) + 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(dir_) + case (psb_sort_up_) + call psi_i_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_i_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_i_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_i_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,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if end if - end if - - - return + + + return 9999 call psb_error_handler(err_act) - return + return + -contains + end subroutine psb_imsort - subroutine in_msort_up(n,k,l,iret) + subroutine psi_i_msort_up(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -432,9 +433,9 @@ contains end do outer end do mergepass - end subroutine in_msort_up + end subroutine psi_i_msort_up - subroutine in_msort_dw(n,k,l,iret) + subroutine psi_i_msort_dw(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -536,9 +537,9 @@ contains end do outer end do mergepass - end subroutine in_msort_dw + end subroutine psi_i_msort_dw - subroutine in_amsort_up(n,k,l,iret) + subroutine psi_i_amsort_up(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -640,9 +641,9 @@ contains end do outer end do mergepass - end subroutine in_amsort_up + end subroutine psi_i_amsort_up - subroutine in_amsort_dw(n,k,l,iret) + subroutine psi_i_amsort_dw(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -744,10 +745,8 @@ contains end do outer end do mergepass - end subroutine in_amsort_dw - + end subroutine psi_i_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 index 2eeb0f8c..f16e0e92 100644 --- a/base/serial/sort/psb_i_qsort_impl.f90 +++ b/base/serial/sort/psb_i_qsort_impl.f90 @@ -48,7 +48,7 @@ subroutine psb_iqsort(x,ix,dir,flag) 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_) :: dir_, flag_, n, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -129,15 +129,13 @@ subroutine psb_iqsort(x,ix,dir,flag) return end subroutine psb_iqsort - - -subroutine psi_iqsrx_up(n,x,ix) +subroutine psi_iqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. integer(psb_ipk_) :: piv, xk, xt @@ -170,40 +168,40 @@ subroutine psi_iqsrx_up(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -228,11 +226,11 @@ subroutine psi_iqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -254,14 +252,14 @@ subroutine psi_iqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_iisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_iisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_iisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -269,29 +267,29 @@ subroutine psi_iqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_iisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_iisrx_up(n2,x(i:iux),idx(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)) + call psi_iisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_iisrx_up(n,x,indx) + call psi_iisrx_up(n,x,idx) endif end subroutine psi_iqsrx_up -subroutine psi_iqsrx_dw(n,x,ix) +subroutine psi_iqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. integer(psb_ipk_) :: piv, xk, xt @@ -324,40 +322,40 @@ subroutine psi_iqsrx_dw(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -382,11 +380,11 @@ subroutine psi_iqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -408,14 +406,14 @@ subroutine psi_iqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_iisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_iisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_iisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -423,19 +421,19 @@ subroutine psi_iqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_iisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_iisrx_dw(n2,x(i:iux),idx(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)) + call psi_iisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_iisrx_dw(n,x,indx) + call psi_iisrx_dw(n,x,idx) endif end subroutine psi_iqsrx_dw @@ -590,7 +588,7 @@ subroutine psi_iqsr_dw(n,x) integer(psb_ipk_), intent(in) :: n ! .. ! .. Local Scalars .. - integer(@FKIND) :: piv, xt, xk + integer(psb_ipk_) :: piv, xt, xk integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: n1, n2 @@ -722,16 +720,17 @@ subroutine psi_iqsr_dw(n,x) end subroutine psi_iqsr_dw -subroutine psi_iaqsrx_up(n,x,ix) +subroutine psi_iaqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: piv, xk + integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -761,39 +760,39 @@ subroutine psi_iaqsrx_up(n,x,ix) piv = abs(x(lpiv)) if (piv < abs(x(i))) then xt = x(i) - ixt = indx(i) + ixt = idx(i) x(i) = x(lpiv) - indx(i) = indx(lpiv) + idx(i) = idx(lpiv) x(lpiv) = xt - indx(lpiv) = ixt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -818,11 +817,11 @@ subroutine psi_iaqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -844,14 +843,14 @@ subroutine psi_iaqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_iaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_iaisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_iaisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -859,34 +858,35 @@ subroutine psi_iaqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_iaisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_iaisrx_up(n2,x(i:iux),idx(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)) + call psi_iaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_iaisrx_up(n,x,indx) + call psi_iaisrx_up(n,x,idx) endif end subroutine psi_iaqsrx_up -subroutine psi_iaqsrx_dw(n,x,ix) +subroutine psi_iaqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: piv, xk + integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -915,39 +915,39 @@ subroutine psi_iaqsrx_dw(n,x,ix) 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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -972,11 +972,11 @@ subroutine psi_iaqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -998,14 +998,14 @@ subroutine psi_iaqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_iaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_iaisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_iaisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1013,19 +1013,19 @@ subroutine psi_iaqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_iaisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_iaisrx_dw(n2,x(i:iux),idx(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)) + call psi_iaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_iaisrx_dw(n,x,indx) + call psi_iaisrx_dw(n,x,idx) endif end subroutine psi_iaqsrx_dw @@ -1038,7 +1038,8 @@ subroutine psi_iaqsr_up(n,x) integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: piv, xk + integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -1177,7 +1178,8 @@ subroutine psi_iaqsr_dw(n,x) integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - integer(psb_ipk_) :: piv, xk, xt + integer(psb_ipk_) :: piv, xk + integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 diff --git a/base/serial/sort/psb_s_isort_impl.f90 b/base/serial/sort/psb_s_isort_impl.f90 index a2c30528..1efb30b2 100644 --- a/base/serial/sort/psb_s_isort_impl.f90 +++ b/base/serial/sort/psb_s_isort_impl.f90 @@ -129,12 +129,12 @@ subroutine psb_sisort(x,ix,dir,flag) return end subroutine psb_sisort -subroutine psi_sisrx_up(n,x,ix) +subroutine psi_sisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_spk_) :: xx @@ -157,12 +157,12 @@ subroutine psi_sisrx_up(n,x,ix) enddo end subroutine psi_sisrx_up -subroutine psi_sisrx_dw(n,x,ix) +subroutine psi_sisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_spk_) :: xx @@ -234,12 +234,12 @@ subroutine psi_sisr_dw(n,x) enddo end subroutine psi_sisr_dw -subroutine psi_saisrx_up(n,x,ix) +subroutine psi_saisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_spk_) :: xx @@ -262,12 +262,12 @@ subroutine psi_saisrx_up(n,x,ix) enddo end subroutine psi_saisrx_up -subroutine psi_saisrx_dw(n,x,ix) +subroutine psi_saisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix real(psb_spk_) :: xx diff --git a/base/serial/sort/psb_s_msort_impl.f90 b/base/serial/sort/psb_s_msort_impl.f90 index 8e1bf1e4..c589a975 100644 --- a/base/serial/sort/psb_s_msort_impl.f90 +++ b/base/serial/sort/psb_s_msort_impl.f90 @@ -29,117 +29,118 @@ !!$ 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_ + ! + ! 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(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) ! OK keep going case default - ierr(1) = 4; ierr(2) = flag_; + 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 - - 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) + 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 - end if - - - return + + 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(dir_) + case (psb_sort_up_) + call psi_s_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_s_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_s_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_s_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,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + end if + + + return 9999 call psb_error_handler(err_act) - return + return + -contains + end subroutine psb_smsort - subroutine in_msort_up(n,k,l,iret) + subroutine psi_s_msort_up(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -241,9 +242,9 @@ contains end do outer end do mergepass - end subroutine in_msort_up + end subroutine psi_s_msort_up - subroutine in_msort_dw(n,k,l,iret) + subroutine psi_s_msort_dw(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -345,9 +346,9 @@ contains end do outer end do mergepass - end subroutine in_msort_dw + end subroutine psi_s_msort_dw - subroutine in_amsort_up(n,k,l,iret) + subroutine psi_s_amsort_up(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -449,9 +450,9 @@ contains end do outer end do mergepass - end subroutine in_amsort_up + end subroutine psi_s_amsort_up - subroutine in_amsort_dw(n,k,l,iret) + subroutine psi_s_amsort_dw(n,k,l,iret) use psb_const_mod implicit none integer(psb_ipk_) :: n, iret @@ -553,10 +554,8 @@ contains end do outer end do mergepass - end subroutine in_amsort_dw - + end subroutine psi_s_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 index 66e3de32..a07d3e2b 100644 --- a/base/serial/sort/psb_s_qsort_impl.f90 +++ b/base/serial/sort/psb_s_qsort_impl.f90 @@ -48,7 +48,7 @@ subroutine psb_sqsort(x,ix,dir,flag) 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_) :: dir_, flag_, n, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -129,15 +129,13 @@ subroutine psb_sqsort(x,ix,dir,flag) return end subroutine psb_sqsort - - -subroutine psi_sqsrx_up(n,x,ix) +subroutine psi_sqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. real(psb_spk_) :: piv, xk, xt @@ -170,40 +168,40 @@ subroutine psi_sqsrx_up(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -228,11 +226,11 @@ subroutine psi_sqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -254,14 +252,14 @@ subroutine psi_sqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_sisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_sisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_sisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -269,29 +267,29 @@ subroutine psi_sqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_sisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_sisrx_up(n2,x(i:iux),idx(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)) + call psi_sisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_sisrx_up(n,x,indx) + call psi_sisrx_up(n,x,idx) endif end subroutine psi_sqsrx_up -subroutine psi_sqsrx_dw(n,x,ix) +subroutine psi_sqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. real(psb_spk_) :: piv, xk, xt @@ -324,40 +322,40 @@ subroutine psi_sqsrx_dw(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -382,11 +380,11 @@ subroutine psi_sqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -408,14 +406,14 @@ subroutine psi_sqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_sisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_sisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_sisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -423,19 +421,19 @@ subroutine psi_sqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_sisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_sisrx_dw(n2,x(i:iux),idx(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)) + call psi_sisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_sisrx_dw(n,x,indx) + call psi_sisrx_dw(n,x,idx) endif end subroutine psi_sqsrx_dw @@ -590,7 +588,7 @@ subroutine psi_sqsr_dw(n,x) integer(psb_ipk_), intent(in) :: n ! .. ! .. Local Scalars .. - real(@FKIND) :: piv, xt, xk + real(psb_spk_) :: piv, xt, xk integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: n1, n2 @@ -722,16 +720,17 @@ subroutine psi_sqsr_dw(n,x) end subroutine psi_sqsr_dw -subroutine psi_saqsrx_up(n,x,ix) +subroutine psi_saqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -761,39 +760,39 @@ subroutine psi_saqsrx_up(n,x,ix) piv = abs(x(lpiv)) if (piv < abs(x(i))) then xt = x(i) - ixt = indx(i) + ixt = idx(i) x(i) = x(lpiv) - indx(i) = indx(lpiv) + idx(i) = idx(lpiv) x(lpiv) = xt - indx(lpiv) = ixt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -818,11 +817,11 @@ subroutine psi_saqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -844,14 +843,14 @@ subroutine psi_saqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_saisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_saisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_saisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -859,34 +858,35 @@ subroutine psi_saqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_saisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_saisrx_up(n2,x(i:iux),idx(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)) + call psi_saisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_saisrx_up(n,x,indx) + call psi_saisrx_up(n,x,idx) endif end subroutine psi_saqsrx_up -subroutine psi_saqsrx_dw(n,x,ix) +subroutine psi_saqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -915,39 +915,39 @@ subroutine psi_saqsrx_dw(n,x,ix) 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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -972,11 +972,11 @@ subroutine psi_saqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -998,14 +998,14 @@ subroutine psi_saqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_saisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_saisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_saisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1013,19 +1013,19 @@ subroutine psi_saqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_saisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_saisrx_dw(n2,x(i:iux),idx(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)) + call psi_saisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_saisrx_dw(n,x,indx) + call psi_saisrx_dw(n,x,idx) endif end subroutine psi_saqsrx_dw @@ -1038,7 +1038,8 @@ subroutine psi_saqsr_up(n,x) real(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -1177,7 +1178,8 @@ subroutine psi_saqsr_dw(n,x) real(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - real(psb_spk_) :: piv, xk, xt + real(psb_spk_) :: piv, xk + real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 diff --git a/base/serial/sort/psb_z_hsort_impl.f90 b/base/serial/sort/psb_z_hsort_impl.f90 index 98117a42..f4164ea2 100644 --- a/base/serial/sort/psb_z_hsort_impl.f90 +++ b/base/serial/sort/psb_z_hsort_impl.f90 @@ -50,7 +50,7 @@ subroutine psb_zhsort(x,ix,dir,flag) integer(psb_ipk_), optional, intent(inout) :: ix(:) integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info - real(psb_spk_) :: key + complex(psb_dpk_) :: key integer(psb_ipk_) :: index integer(psb_ipk_) :: ierr(5) @@ -391,7 +391,7 @@ contains 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 + use psb_z_sort_mod, psb_protect_name => psi_z_heap_get_first implicit none ! @@ -633,7 +633,7 @@ contains 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 + use psb_z_sort_mod, psb_protect_name => psi_z_idx_insert_heap implicit none ! @@ -869,7 +869,7 @@ 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 + use psb_z_sort_mod, psb_protect_name => psi_z_idx_heap_get_first implicit none ! @@ -905,22 +905,22 @@ subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info) info = -4 case (psb_asort_up_) - call fix_aup(last,heap) + call fix_aup(last,heap,idxs) case (psb_asort_down_) - call fix_adw(last,heap) + call fix_adw(last,heap,idxs) case (psb_alsort_up_) - call fix_alup(last,heap) + call fix_alup(last,heap,idxs) case (psb_alsort_down_) - call fix_aldw(last,heap) + call fix_aldw(last,heap,idxs) case (psb_lsort_up_) - call fix_lup(last,heap) + call fix_lup(last,heap,idxs) case (psb_lsort_down_) - call fix_ldw(last,heap) + call fix_ldw(last,heap,idxs) case default write(psb_err_unit,*) 'Invalid direction in heap ',dir @@ -933,7 +933,7 @@ contains use psi_acx_mod integer(psb_ipk_), intent(in) :: last complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_dpk_) :: temp @@ -968,7 +968,7 @@ contains use psi_acx_mod integer(psb_ipk_), intent(in) :: last complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_dpk_) :: temp @@ -1002,7 +1002,7 @@ contains use psi_lcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_dpk_) :: temp @@ -1036,7 +1036,7 @@ contains use psi_lcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_dpk_) :: temp @@ -1070,7 +1070,7 @@ contains use psi_alcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_dpk_) :: temp @@ -1104,7 +1104,7 @@ contains use psi_alcx_mod integer(psb_ipk_), intent(in) :: last complex(psb_dpk_), intent(inout) :: heap(:) - integer(psb_ipk) :: idxs(:) + integer(psb_ipk_) :: idxs(:) integer(psb_ipk_) :: i,j, itemp complex(psb_dpk_) :: temp @@ -1134,7 +1134,7 @@ contains end subroutine fix_aldw -end subroutine psi_z_heap_get_first +end subroutine psi_z_idx_heap_get_first diff --git a/base/serial/sort/psb_z_isort_impl.f90 b/base/serial/sort/psb_z_isort_impl.f90 index 3e5ae436..124798fe 100644 --- a/base/serial/sort/psb_z_isort_impl.f90 +++ b/base/serial/sort/psb_z_isort_impl.f90 @@ -137,13 +137,13 @@ subroutine psb_zisort(x,ix,dir,flag) return end subroutine psb_zisort -subroutine psi_zlisrx_up(n,x,ix) +subroutine psi_zlisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_dpk_) :: xx @@ -167,13 +167,13 @@ subroutine psi_zlisrx_up(n,x,ix) end subroutine psi_zlisrx_up -subroutine psi_zlisrx_dw(n,x,ix) +subroutine psi_zlisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_dpk_) :: xx @@ -246,13 +246,13 @@ subroutine psi_zlisr_dw(n,x) enddo end subroutine psi_zlisr_dw -subroutine psi_zalisrx_up(n,x,ix) +subroutine psi_zalisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_dpk_) :: xx @@ -275,13 +275,13 @@ subroutine psi_zalisrx_up(n,x,ix) enddo end subroutine psi_zalisrx_up -subroutine psi_zalisrx_dw(n,x,ix) +subroutine psi_zalisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_dpk_) :: xx @@ -354,12 +354,12 @@ subroutine psi_zalisr_dw(n,x) enddo end subroutine psi_zalisr_dw -subroutine psi_zaisrx_up(n,x,ix) +subroutine psi_zaisrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_dpk_) :: xx @@ -382,12 +382,12 @@ subroutine psi_zaisrx_up(n,x,ix) enddo end subroutine psi_zaisrx_up -subroutine psi_zaisrx_dw(n,x,ix) +subroutine psi_zaisrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: i,j,ix complex(psb_dpk_) :: xx diff --git a/base/serial/sort/psb_z_msort_impl.f90 b/base/serial/sort/psb_z_msort_impl.f90 index 40920ded..79c9a7cc 100644 --- a/base/serial/sort/psb_z_msort_impl.f90 +++ b/base/serial/sort/psb_z_msort_impl.f90 @@ -29,127 +29,128 @@ !!$ 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 -! - - + ! + ! 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 + 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(:) - name='psb_zmsort' - call psb_erractionsave(err_act) + integer(psb_ipk_) :: dir_, flag_, n, 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 + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name - n = size(x) + name='psb_zmsort' + call psb_erractionsave(err_act) - 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_ + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ end if - select case(flag_) - case(psb_sort_ovw_idx_) - do i=1,n - ix(i) = i - end do - case (psb_sort_keep_idx_) + 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) = 4; ierr(2) = flag_; + 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 - - 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) + + 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 - end if - - return + + 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(dir_) + case (psb_lsort_up_) + call psi_z_lmsort_up(n,x,iaux,iret) + case (psb_lsort_down_) + call psi_z_lmsort_dw(n,x,iaux,iret) + case (psb_alsort_up_) + call psi_z_almsort_up(n,x,iaux,iret) + case (psb_alsort_down_) + call psi_z_almsort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_z_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_z_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,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + end if + + return 9999 call psb_error_handler(err_act) - return + return + -contains + end subroutine psb_zmsort - subroutine in_lmsort_up(n,k,l,iret) + subroutine psi_z_lmsort_up(n,k,l,iret) use psb_const_mod use psi_lcx_mod implicit none @@ -252,9 +253,9 @@ contains end do outer end do mergepass - end subroutine in_lmsort_up + end subroutine psi_z_lmsort_up - subroutine in_lmsort_dw(n,k,l,iret) + subroutine psi_z_lmsort_dw(n,k,l,iret) use psb_const_mod use psi_lcx_mod implicit none @@ -357,9 +358,9 @@ contains end do outer end do mergepass - end subroutine in_lmsort_dw + end subroutine psi_z_lmsort_dw - subroutine in_amsort_up(n,k,l,iret) + subroutine psi_z_amsort_up(n,k,l,iret) use psb_const_mod use psi_acx_mod implicit none @@ -462,9 +463,9 @@ contains end do outer end do mergepass - end subroutine in_amsort_up + end subroutine psi_z_amsort_up - subroutine in_amsort_dw(n,k,l,iret) + subroutine psi_z_amsort_dw(n,k,l,iret) use psb_const_mod use psi_acx_mod implicit none @@ -567,9 +568,9 @@ contains end do outer end do mergepass - end subroutine in_amsort_dw + end subroutine psi_z_amsort_dw - subroutine in_almsort_up(n,k,l,iret) + subroutine psi_z_almsort_up(n,k,l,iret) use psb_const_mod use psi_alcx_mod implicit none @@ -672,9 +673,9 @@ contains end do outer end do mergepass - end subroutine in_almsort_up + end subroutine psi_z_almsort_up - subroutine in_almsort_dw(n,k,l,iret) + subroutine psi_z_almsort_dw(n,k,l,iret) use psb_const_mod use psi_alcx_mod implicit none @@ -777,6 +778,5 @@ contains end do outer end do mergepass - end subroutine in_almsort_dw + end subroutine psi_z_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 index 9823b086..bf09e9bb 100644 --- a/base/serial/sort/psb_z_qsort_impl.f90 +++ b/base/serial/sort/psb_z_qsort_impl.f90 @@ -48,7 +48,7 @@ subroutine psb_zqsort(x,ix,dir,flag) 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_) :: dir_, flag_, n, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -138,607 +138,14 @@ subroutine psb_zqsort(x,ix,dir,flag) 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) +subroutine psi_zlqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt @@ -771,40 +178,40 @@ subroutine psi_zlqsrx_up(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -829,11 +236,11 @@ subroutine psi_zlqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -855,14 +262,14 @@ subroutine psi_zlqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_zlisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_zlisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_zlisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -870,31 +277,31 @@ subroutine psi_zlqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_zlisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_zlisrx_up(n2,x(i:iux),idx(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)) + call psi_zlisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_zlisrx_up(n,x,indx) + call psi_zlisrx_up(n,x,idx) endif end subroutine psi_zlqsrx_up -subroutine psi_zlqsrx_dw(n,x,ix) +subroutine psi_zlqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt @@ -927,40 +334,40 @@ subroutine psi_zlqsrx_dw(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -985,11 +392,11 @@ subroutine psi_zlqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -1011,14 +418,14 @@ subroutine psi_zlqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_zlisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_zlisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_zlisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1026,19 +433,19 @@ subroutine psi_zlqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_zlisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_zlisrx_dw(n2,x(i:iux),idx(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)) + call psi_zlisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_zlisrx_dw(n,x,indx) + call psi_zlisrx_dw(n,x,idx) endif end subroutine psi_zlqsrx_dw @@ -1193,7 +600,7 @@ subroutine psi_zlqsr_dw(n,x) complex(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(@FKIND) :: piv, xt, xk + complex(psb_dpk_) :: piv, xt, xk integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: n1, n2 @@ -1325,14 +732,14 @@ subroutine psi_zlqsr_dw(n,x) end subroutine psi_zlqsr_dw -subroutine psi_zalqsrx_up(n,x,ix) +subroutine psi_zalqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt @@ -1365,40 +772,40 @@ subroutine psi_zalqsrx_up(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -1423,11 +830,11 @@ subroutine psi_zalqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -1449,14 +856,14 @@ subroutine psi_zalqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_zalisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_zalisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_zalisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1464,30 +871,30 @@ subroutine psi_zalqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_zalisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_zalisrx_up(n2,x(i:iux),idx(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)) + call psi_zalisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_zalisrx_up(n,x,indx) + call psi_zalisrx_up(n,x,idx) endif end subroutine psi_zalqsrx_up -subroutine psi_zalqsrx_dw(n,x,ix) +subroutine psi_zalqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt @@ -1520,40 +927,40 @@ subroutine psi_zalqsrx_dw(n,x,ix) 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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) i = ilx - 1 j = iux + 1 @@ -1578,11 +985,11 @@ subroutine psi_zalqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -1604,14 +1011,14 @@ subroutine psi_zalqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_zalisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_zalisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_zalisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -1619,19 +1026,19 @@ subroutine psi_zalqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_zalisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_zalisrx_dw(n2,x(i:iux),idx(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)) + call psi_zalisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_zalisrx_dw(n,x,indx) + call psi_zalisrx_dw(n,x,idx) endif end subroutine psi_zalqsrx_dw @@ -1785,7 +1192,7 @@ subroutine psi_zalqsr_dw(n,x) complex(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(@FKIND) :: piv, xt, xk + complex(psb_dpk_) :: piv, xt, xk integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: n1, n2 @@ -1916,16 +1323,17 @@ subroutine psi_zalqsr_dw(n,x) endif end subroutine psi_zalqsr_dw -subroutine psi_zaqsrx_up(n,x,ix) +subroutine psi_zaqsrx_up(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -1955,39 +1363,39 @@ subroutine psi_zaqsrx_up(n,x,ix) piv = abs(x(lpiv)) if (piv < abs(x(i))) then xt = x(i) - ixt = indx(i) + ixt = idx(i) x(i) = x(lpiv) - indx(i) = indx(lpiv) + idx(i) = idx(lpiv) x(lpiv) = xt - indx(lpiv) = ixt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -2012,11 +1420,11 @@ subroutine psi_zaqsrx_up(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_up end if @@ -2038,14 +1446,14 @@ subroutine psi_zaqsrx_up(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_zaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_zaisrx_up(n1,x(ilx:i-1),idx(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)) + call psi_zaisrx_up(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -2053,34 +1461,35 @@ subroutine psi_zaqsrx_up(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_zaisrx_up(n2,x(i:iux),indx(i:iux)) + call psi_zaisrx_up(n2,x(i:iux),idx(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)) + call psi_zaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_zaisrx_up(n,x,indx) + call psi_zaisrx_up(n,x,idx) endif end subroutine psi_zaqsrx_up -subroutine psi_zaqsrx_dw(n,x,ix) +subroutine psi_zaqsrx_dw(n,x,idx) 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(inout) :: idx(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -2109,39 +1518,39 @@ subroutine psi_zaqsrx_dw(n,x,ix) 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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(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 + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt i = ilx - 1 j = iux + 1 @@ -2166,11 +1575,11 @@ subroutine psi_zaqsrx_dw(n,x,ix) if (j > i) then xt = x(i) - ixt = indx(i) - x(i) = x(j) - indx(i) = indx(j) - x(j) = xt - indx(j) = ixt + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt else exit outer_dw end if @@ -2192,14 +1601,14 @@ subroutine psi_zaqsrx_dw(n,x,ix) istack(1,istp) = ilx istack(2,istp) = i-1 else - call psi_zaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + call psi_zaisrx_dw(n1,x(ilx:i-1),idx(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)) + call psi_zaisrx_dw(n2,x(i:iux),idx(i:iux)) endif else if (n2 > ithrs) then @@ -2207,19 +1616,19 @@ subroutine psi_zaqsrx_dw(n,x,ix) istack(1,istp) = i istack(2,istp) = iux else - call psi_zaisrx_dw(n2,x(i:iux),indx(i:iux)) + call psi_zaisrx_dw(n2,x(i:iux),idx(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)) + call psi_zaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) endif endif enddo else - call psi_zaisrx_dw(n,x,indx) + call psi_zaisrx_dw(n,x,idx) endif end subroutine psi_zaqsrx_dw @@ -2232,7 +1641,8 @@ subroutine psi_zaqsr_up(n,x) complex(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 @@ -2371,7 +1781,8 @@ subroutine psi_zaqsr_dw(n,x) complex(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: n ! .. Local Scalars .. - complex(psb_dpk_) :: piv, xk, xt + real(psb_dpk_) :: piv, xk + complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv integer(psb_ipk_) :: ixt, n1, n2 diff --git a/base/serial/sort/psi_alcx_mod.f90 b/base/serial/sort/psi_alcx_mod.f90 index e4dcbebc..100a2f02 100644 --- a/base/serial/sort/psi_alcx_mod.f90 +++ b/base/serial/sort/psi_alcx_mod.f90 @@ -29,7 +29,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -module psi_lcx_mod +module psi_alcx_mod use psb_const_mod interface operator(<) module procedure psi_callt, psi_zallt @@ -126,5 +126,5 @@ contains & (abs(aimag(a))>=abs(aimag(b)))) end function psi_zalge -end module psi_lcx_mod +end module psi_alcx_mod