|
|
|
|
@ -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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Salvatore Filippone
10 years ago