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

psblas-submodules:

Browse Source 
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_z_sort_mod.f90
 base/serial/sort/psb_c_hsort_impl.f90
 base/serial/sort/psb_c_isort_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_qsort_impl.f90
 base/serial/sort/psb_i_hsort_impl.f90
 base/serial/sort/psb_i_isort_impl.f90
 base/serial/sort/psb_i_qsort_impl.f90
 base/serial/sort/psb_s_hsort_impl.f90
 base/serial/sort/psb_s_isort_impl.f90
 base/serial/sort/psb_s_qsort_impl.f90
 base/serial/sort/psb_z_hsort_impl.f90
 base/serial/sort/psb_z_isort_impl.f90
 base/serial/sort/psb_z_qsort_impl.f90

interface/implementation minor mismatch fixes
psblas3-submodules
Salvatore Filippone 10 years ago
parent 0ed792f1f7
commit 7e5d678161
20 changed files with 697 additions and 697 deletions
Show Stats Download Patch File Download Diff File

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

@ -190,7 +190,7 @@ module psb_c_sort_mod
interface interface
module subroutine psi_c_heap_get_first(key,last,heap,dir,info) module subroutine psi_c_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
complex(psb_spk_), intent(inout) :: key complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:) complex(psb_spk_), intent(inout) :: heap(:)

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

@ -178,7 +178,7 @@ module psb_d_sort_mod
interface interface
module subroutine psi_d_heap_get_first(key,last,heap,dir,info) module subroutine psi_d_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
real(psb_dpk_), intent(inout) :: key real(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(inout) :: heap(:) real(psb_dpk_), intent(inout) :: heap(:)

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

@ -215,7 +215,7 @@ module psb_i_sort_mod
interface interface
module subroutine psi_i_heap_get_first(key,last,heap,dir,info) module subroutine psi_i_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
integer(psb_ipk_), intent(inout) :: key integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(inout) :: heap(:)

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

@ -178,7 +178,7 @@ module psb_s_sort_mod
interface interface
module subroutine psi_s_heap_get_first(key,last,heap,dir,info) module subroutine psi_s_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
real(psb_spk_), intent(inout) :: key real(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(inout) :: heap(:) real(psb_spk_), intent(inout) :: heap(:)

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

@ -190,7 +190,7 @@ module psb_z_sort_mod
interface interface
module subroutine psi_z_heap_get_first(key,last,heap,dir,info) module subroutine psi_z_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
complex(psb_dpk_), intent(inout) :: key complex(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
complex(psb_dpk_), intent(inout) :: heap(:) complex(psb_dpk_), intent(inout) :: heap(:)

14
base/serial/sort/psb_c_hsort_impl.f90
Unescape Escape View File

@ -42,7 +42,7 @@
! Addison-Wesley ! Addison-Wesley
! !
submodule (psb_c_sort_mod) psb_c_hsort_impl_mod submodule (psb_c_sort_mod) psb_c_hsort_impl_mod
contains contains
subroutine psb_chsort(x,ix,dir,flag) subroutine psb_chsort(x,ix,dir,flag)
@ -402,9 +402,9 @@ contains
! heap: the heap ! heap: the heap
! dir: sorting direction ! dir: sorting direction
complex(psb_spk_), intent(inout) :: key complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:) complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -878,9 +878,9 @@ contains
! heap: the heap ! heap: the heap
! dir: sorting direction ! dir: sorting direction
complex(psb_spk_), intent(inout) :: key complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:) complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:) integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last

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

@ -139,59 +139,59 @@ contains
return return
end subroutine psb_cisort end subroutine psb_cisort
subroutine psi_clisrx_up(n,x,idx) subroutine psi_clisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_spk_) :: xx complex(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) < x(j)) then if (x(j+1) < x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) >= xx) exit if (x(i) >= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_clisrx_up end subroutine psi_clisrx_up
subroutine psi_clisrx_dw(n,x,idx) subroutine psi_clisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_spk_) :: xx complex(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) > x(j)) then if (x(j+1) > x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) <= xx) exit if (x(i) <= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_clisrx_dw end subroutine psi_clisrx_dw
@ -244,58 +244,58 @@ contains
enddo enddo
end subroutine psi_clisr_dw end subroutine psi_clisr_dw
subroutine psi_calisrx_up(n,x,idx) subroutine psi_calisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_spk_) :: xx complex(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) < x(j)) then if (x(j+1) < x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) >= xx) exit if (x(i) >= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_calisrx_up end subroutine psi_calisrx_up
subroutine psi_calisrx_dw(n,x,idx) subroutine psi_calisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_spk_) :: xx complex(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) > x(j)) then if (x(j+1) > x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) <= xx) exit if (x(i) <= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_calisrx_dw end subroutine psi_calisrx_dw
@ -348,56 +348,56 @@ contains
enddo enddo
end subroutine psi_calisr_dw end subroutine psi_calisr_dw
subroutine psi_caisrx_up(n,x,idx) subroutine psi_caisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_spk_) :: xx complex(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then if (abs(x(j+1)) < abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit if (abs(x(i)) >= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_caisrx_up end subroutine psi_caisrx_up
subroutine psi_caisrx_dw(n,x,idx) subroutine psi_caisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_spk_) :: xx complex(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then if (abs(x(j+1)) > abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit if (abs(x(i)) <= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_caisrx_dw end subroutine psi_caisrx_dw

264
base/serial/sort/psb_c_qsort_impl.f90
Unescape Escape View File

@ -140,13 +140,13 @@ contains
end subroutine psb_cqsort end subroutine psb_cqsort
subroutine psi_clqsrx_up(n,x,idx) subroutine psi_clqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_spk_) :: piv, xk, xt complex(psb_spk_) :: piv, xk, xt
@ -179,39 +179,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -237,11 +237,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -263,14 +263,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_clisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_clisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_clisrx_up(n2,x(i:iux),idx(i:iux)) call psi_clisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -278,30 +278,30 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_clisrx_up(n2,x(i:iux),idx(i:iux)) call psi_clisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_clisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_clisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_clisrx_up(n,x,idx) call psi_clisrx_up(n,x,ix)
endif endif
end subroutine psi_clqsrx_up end subroutine psi_clqsrx_up
subroutine psi_clqsrx_dw(n,x,idx) subroutine psi_clqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_spk_) :: piv, xk, xt complex(psb_spk_) :: piv, xk, xt
@ -334,39 +334,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -392,11 +392,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -418,14 +418,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_clisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_clisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_clisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_clisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -433,19 +433,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_clisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_clisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_clisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_clisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_clisrx_dw(n,x,idx) call psi_clisrx_dw(n,x,ix)
endif endif
end subroutine psi_clqsrx_dw end subroutine psi_clqsrx_dw
@ -730,13 +730,13 @@ contains
end subroutine psi_clqsr_dw end subroutine psi_clqsr_dw
subroutine psi_calqsrx_up(n,x,idx) subroutine psi_calqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_spk_) :: piv, xk, xt complex(psb_spk_) :: piv, xk, xt
@ -769,39 +769,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -827,11 +827,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -853,14 +853,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_calisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_calisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_calisrx_up(n2,x(i:iux),idx(i:iux)) call psi_calisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -868,29 +868,29 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_calisrx_up(n2,x(i:iux),idx(i:iux)) call psi_calisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_calisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_calisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_calisrx_up(n,x,idx) call psi_calisrx_up(n,x,ix)
endif endif
end subroutine psi_calqsrx_up end subroutine psi_calqsrx_up
subroutine psi_calqsrx_dw(n,x,idx) subroutine psi_calqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_spk_) :: piv, xk, xt complex(psb_spk_) :: piv, xk, xt
@ -923,39 +923,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -981,11 +981,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -1007,14 +1007,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_calisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_calisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_calisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_calisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1022,19 +1022,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_calisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_calisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_calisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_calisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_calisrx_dw(n,x,idx) call psi_calisrx_dw(n,x,ix)
endif endif
end subroutine psi_calqsrx_dw end subroutine psi_calqsrx_dw
@ -1317,12 +1317,12 @@ contains
endif endif
end subroutine psi_calqsr_dw end subroutine psi_calqsr_dw
subroutine psi_caqsrx_up(n,x,idx) subroutine psi_caqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_spk_) :: piv, xk real(psb_spk_) :: piv, xk
@ -1356,39 +1356,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(j))) then if (piv > abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -1413,11 +1413,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -1439,14 +1439,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_caisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_caisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_caisrx_up(n2,x(i:iux),idx(i:iux)) call psi_caisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1454,30 +1454,30 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_caisrx_up(n2,x(i:iux),idx(i:iux)) call psi_caisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_caisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_caisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_caisrx_up(n,x,idx) call psi_caisrx_up(n,x,ix)
endif endif
end subroutine psi_caqsrx_up end subroutine psi_caqsrx_up
subroutine psi_caqsrx_dw(n,x,idx) subroutine psi_caqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_spk_) :: piv, xk real(psb_spk_) :: piv, xk
@ -1510,39 +1510,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(j))) then if (piv < abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -1567,11 +1567,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -1593,14 +1593,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_caisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_caisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_caisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_caisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1608,19 +1608,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_caisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_caisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_caisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_caisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_caisrx_dw(n,x,idx) call psi_caisrx_dw(n,x,ix)
endif endif
end subroutine psi_caqsrx_dw end subroutine psi_caqsrx_dw

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

@ -42,7 +42,7 @@
! Addison-Wesley ! Addison-Wesley
! !
submodule (psb_d_sort_mod) psb_d_hsort_impl_mod submodule (psb_d_sort_mod) psb_d_hsort_impl_mod
contains contains
subroutine psb_dhsort(x,ix,dir,flag) subroutine psb_dhsort(x,ix,dir,flag)
@ -295,7 +295,7 @@ contains
subroutine psi_d_heap_get_first(key,last,heap,dir,info) subroutine psi_d_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
real(psb_dpk_), intent(inout) :: key real(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
real(psb_dpk_), intent(inout) :: heap(:) real(psb_dpk_), intent(inout) :: heap(:)

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

@ -131,56 +131,56 @@ contains
return return
end subroutine psb_disort end subroutine psb_disort
subroutine psi_disrx_up(n,x,idx) subroutine psi_disrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx real(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) < x(j)) then if (x(j+1) < x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) >= xx) exit if (x(i) >= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_disrx_up end subroutine psi_disrx_up
subroutine psi_disrx_dw(n,x,idx) subroutine psi_disrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx real(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) > x(j)) then if (x(j+1) > x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) <= xx) exit if (x(i) <= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_disrx_dw end subroutine psi_disrx_dw
@ -232,56 +232,56 @@ contains
enddo enddo
end subroutine psi_disr_dw end subroutine psi_disr_dw
subroutine psi_daisrx_up(n,x,idx) subroutine psi_daisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx real(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then if (abs(x(j+1)) < abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit if (abs(x(i)) >= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_daisrx_up end subroutine psi_daisrx_up
subroutine psi_daisrx_dw(n,x,idx) subroutine psi_daisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx real(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then if (abs(x(j+1)) > abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit if (abs(x(i)) <= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_daisrx_dw end subroutine psi_daisrx_dw

176
base/serial/sort/psb_d_qsort_impl.f90
Unescape Escape View File

@ -131,12 +131,12 @@ contains
return return
end subroutine psb_dqsort end subroutine psb_dqsort
subroutine psi_dqsrx_up(n,x,idx) subroutine psi_dqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_dpk_) :: piv, xk, xt real(psb_dpk_) :: piv, xk, xt
@ -169,39 +169,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -227,11 +227,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -253,14 +253,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_disrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_disrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_disrx_up(n2,x(i:iux),idx(i:iux)) call psi_disrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -268,28 +268,28 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_disrx_up(n2,x(i:iux),idx(i:iux)) call psi_disrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_disrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_disrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_disrx_up(n,x,idx) call psi_disrx_up(n,x,ix)
endif endif
end subroutine psi_dqsrx_up end subroutine psi_dqsrx_up
subroutine psi_dqsrx_dw(n,x,idx) subroutine psi_dqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_dpk_) :: piv, xk, xt real(psb_dpk_) :: piv, xk, xt
@ -322,39 +322,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -380,11 +380,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -406,14 +406,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_disrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_disrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_disrx_dw(n2,x(i:iux),idx(i:iux)) call psi_disrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -421,19 +421,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_disrx_dw(n2,x(i:iux),idx(i:iux)) call psi_disrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_disrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_disrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_disrx_dw(n,x,idx) call psi_disrx_dw(n,x,ix)
endif endif
end subroutine psi_dqsrx_dw end subroutine psi_dqsrx_dw
@ -718,12 +718,12 @@ contains
end subroutine psi_dqsr_dw end subroutine psi_dqsr_dw
subroutine psi_daqsrx_up(n,x,idx) subroutine psi_daqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_dpk_) :: piv, xk real(psb_dpk_) :: piv, xk
@ -757,39 +757,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(j))) then if (piv > abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -814,11 +814,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -840,14 +840,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_daisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_daisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_daisrx_up(n2,x(i:iux),idx(i:iux)) call psi_daisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -855,30 +855,30 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_daisrx_up(n2,x(i:iux),idx(i:iux)) call psi_daisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_daisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_daisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_daisrx_up(n,x,idx) call psi_daisrx_up(n,x,ix)
endif endif
end subroutine psi_daqsrx_up end subroutine psi_daqsrx_up
subroutine psi_daqsrx_dw(n,x,idx) subroutine psi_daqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_dpk_) :: piv, xk real(psb_dpk_) :: piv, xk
@ -911,39 +911,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(j))) then if (piv < abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -968,11 +968,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -994,14 +994,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_daisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_daisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_daisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_daisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1009,19 +1009,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_daisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_daisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_daisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_daisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_daisrx_dw(n,x,idx) call psi_daisrx_dw(n,x,ix)
endif endif
end subroutine psi_daqsrx_dw end subroutine psi_daqsrx_dw

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

@ -42,7 +42,7 @@
! Addison-Wesley ! Addison-Wesley
! !
submodule (psb_i_sort_mod) psb_i_hsort_impl_mod submodule (psb_i_sort_mod) psb_i_hsort_impl_mod
contains contains
subroutine psb_ihsort(x,ix,dir,flag) subroutine psb_ihsort(x,ix,dir,flag)
@ -295,7 +295,7 @@ contains
subroutine psi_i_heap_get_first(key,last,heap,dir,info) subroutine psi_i_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
integer(psb_ipk_), intent(inout) :: key integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:) integer(psb_ipk_), intent(inout) :: heap(:)

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

@ -131,56 +131,56 @@ contains
return return
end subroutine psb_iisort end subroutine psb_iisort
subroutine psi_iisrx_up(n,x,idx) subroutine psi_iisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx integer(psb_ipk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) < x(j)) then if (x(j+1) < x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) >= xx) exit if (x(i) >= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_iisrx_up end subroutine psi_iisrx_up
subroutine psi_iisrx_dw(n,x,idx) subroutine psi_iisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx integer(psb_ipk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) > x(j)) then if (x(j+1) > x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) <= xx) exit if (x(i) <= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_iisrx_dw end subroutine psi_iisrx_dw
@ -232,56 +232,56 @@ contains
enddo enddo
end subroutine psi_iisr_dw end subroutine psi_iisr_dw
subroutine psi_iaisrx_up(n,x,idx) subroutine psi_iaisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx integer(psb_ipk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then if (abs(x(j+1)) < abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit if (abs(x(i)) >= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_iaisrx_up end subroutine psi_iaisrx_up
subroutine psi_iaisrx_dw(n,x,idx) subroutine psi_iaisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx integer(psb_ipk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then if (abs(x(j+1)) > abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit if (abs(x(i)) <= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_iaisrx_dw end subroutine psi_iaisrx_dw

176
base/serial/sort/psb_i_qsort_impl.f90
Unescape Escape View File

@ -131,12 +131,12 @@ contains
return return
end subroutine psb_iqsort end subroutine psb_iqsort
subroutine psi_iqsrx_up(n,x,idx) subroutine psi_iqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: piv, xk, xt integer(psb_ipk_) :: piv, xk, xt
@ -169,39 +169,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -227,11 +227,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -253,14 +253,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iisrx_up(n2,x(i:iux),idx(i:iux)) call psi_iisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -268,28 +268,28 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iisrx_up(n2,x(i:iux),idx(i:iux)) call psi_iisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_iisrx_up(n,x,idx) call psi_iisrx_up(n,x,ix)
endif endif
end subroutine psi_iqsrx_up end subroutine psi_iqsrx_up
subroutine psi_iqsrx_dw(n,x,idx) subroutine psi_iqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: piv, xk, xt integer(psb_ipk_) :: piv, xk, xt
@ -322,39 +322,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -380,11 +380,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -406,14 +406,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_iisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -421,19 +421,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_iisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_iisrx_dw(n,x,idx) call psi_iisrx_dw(n,x,ix)
endif endif
end subroutine psi_iqsrx_dw end subroutine psi_iqsrx_dw
@ -718,12 +718,12 @@ contains
end subroutine psi_iqsr_dw end subroutine psi_iqsr_dw
subroutine psi_iaqsrx_up(n,x,idx) subroutine psi_iaqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: piv, xk integer(psb_ipk_) :: piv, xk
@ -757,39 +757,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(j))) then if (piv > abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -814,11 +814,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -840,14 +840,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iaisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iaisrx_up(n2,x(i:iux),idx(i:iux)) call psi_iaisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -855,30 +855,30 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iaisrx_up(n2,x(i:iux),idx(i:iux)) call psi_iaisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iaisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_iaisrx_up(n,x,idx) call psi_iaisrx_up(n,x,ix)
endif endif
end subroutine psi_iaqsrx_up end subroutine psi_iaqsrx_up
subroutine psi_iaqsrx_dw(n,x,idx) subroutine psi_iaqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: piv, xk integer(psb_ipk_) :: piv, xk
@ -911,39 +911,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(j))) then if (piv < abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -968,11 +968,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -994,14 +994,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iaisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iaisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_iaisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1009,19 +1009,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_iaisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_iaisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_iaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_iaisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_iaisrx_dw(n,x,idx) call psi_iaisrx_dw(n,x,ix)
endif endif
end subroutine psi_iaqsrx_dw end subroutine psi_iaqsrx_dw

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

@ -42,7 +42,7 @@
! Addison-Wesley ! Addison-Wesley
! !
submodule (psb_s_sort_mod) psb_s_hsort_impl_mod submodule (psb_s_sort_mod) psb_s_hsort_impl_mod
contains contains
subroutine psb_shsort(x,ix,dir,flag) subroutine psb_shsort(x,ix,dir,flag)
@ -295,7 +295,7 @@ contains
subroutine psi_s_heap_get_first(key,last,heap,dir,info) subroutine psi_s_heap_get_first(key,last,heap,dir,info)
implicit none implicit none
real(psb_spk_), intent(inout) :: key real(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
real(psb_spk_), intent(inout) :: heap(:) real(psb_spk_), intent(inout) :: heap(:)

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

@ -131,56 +131,56 @@ contains
return return
end subroutine psb_sisort end subroutine psb_sisort
subroutine psi_sisrx_up(n,x,idx) subroutine psi_sisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx real(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) < x(j)) then if (x(j+1) < x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) >= xx) exit if (x(i) >= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_sisrx_up end subroutine psi_sisrx_up
subroutine psi_sisrx_dw(n,x,idx) subroutine psi_sisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx real(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) > x(j)) then if (x(j+1) > x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) <= xx) exit if (x(i) <= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_sisrx_dw end subroutine psi_sisrx_dw
@ -232,56 +232,56 @@ contains
enddo enddo
end subroutine psi_sisr_dw end subroutine psi_sisr_dw
subroutine psi_saisrx_up(n,x,idx) subroutine psi_saisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx real(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then if (abs(x(j+1)) < abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit if (abs(x(i)) >= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_saisrx_up end subroutine psi_saisrx_up
subroutine psi_saisrx_dw(n,x,idx) subroutine psi_saisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx real(psb_spk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then if (abs(x(j+1)) > abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit if (abs(x(i)) <= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_saisrx_dw end subroutine psi_saisrx_dw

176
base/serial/sort/psb_s_qsort_impl.f90
Unescape Escape View File

@ -131,12 +131,12 @@ contains
return return
end subroutine psb_sqsort end subroutine psb_sqsort
subroutine psi_sqsrx_up(n,x,idx) subroutine psi_sqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_spk_) :: piv, xk, xt real(psb_spk_) :: piv, xk, xt
@ -169,39 +169,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -227,11 +227,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -253,14 +253,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_sisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_sisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_sisrx_up(n2,x(i:iux),idx(i:iux)) call psi_sisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -268,28 +268,28 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_sisrx_up(n2,x(i:iux),idx(i:iux)) call psi_sisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_sisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_sisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_sisrx_up(n,x,idx) call psi_sisrx_up(n,x,ix)
endif endif
end subroutine psi_sqsrx_up end subroutine psi_sqsrx_up
subroutine psi_sqsrx_dw(n,x,idx) subroutine psi_sqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_spk_) :: piv, xk, xt real(psb_spk_) :: piv, xk, xt
@ -322,39 +322,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -380,11 +380,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -406,14 +406,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_sisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_sisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_sisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_sisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -421,19 +421,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_sisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_sisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_sisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_sisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_sisrx_dw(n,x,idx) call psi_sisrx_dw(n,x,ix)
endif endif
end subroutine psi_sqsrx_dw end subroutine psi_sqsrx_dw
@ -718,12 +718,12 @@ contains
end subroutine psi_sqsr_dw end subroutine psi_sqsr_dw
subroutine psi_saqsrx_up(n,x,idx) subroutine psi_saqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_spk_) :: piv, xk real(psb_spk_) :: piv, xk
@ -757,39 +757,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(j))) then if (piv > abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -814,11 +814,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -840,14 +840,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_saisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_saisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_saisrx_up(n2,x(i:iux),idx(i:iux)) call psi_saisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -855,30 +855,30 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_saisrx_up(n2,x(i:iux),idx(i:iux)) call psi_saisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_saisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_saisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_saisrx_up(n,x,idx) call psi_saisrx_up(n,x,ix)
endif endif
end subroutine psi_saqsrx_up end subroutine psi_saqsrx_up
subroutine psi_saqsrx_dw(n,x,idx) subroutine psi_saqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_spk_) :: piv, xk real(psb_spk_) :: piv, xk
@ -911,39 +911,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(j))) then if (piv < abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -968,11 +968,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -994,14 +994,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_saisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_saisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_saisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_saisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1009,19 +1009,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_saisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_saisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_saisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_saisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_saisrx_dw(n,x,idx) call psi_saisrx_dw(n,x,ix)
endif endif
end subroutine psi_saqsrx_dw end subroutine psi_saqsrx_dw

14
base/serial/sort/psb_z_hsort_impl.f90
Unescape Escape View File

@ -42,7 +42,7 @@
! Addison-Wesley ! Addison-Wesley
! !
submodule (psb_z_sort_mod) psb_z_hsort_impl_mod submodule (psb_z_sort_mod) psb_z_hsort_impl_mod
contains contains
subroutine psb_zhsort(x,ix,dir,flag) subroutine psb_zhsort(x,ix,dir,flag)
@ -402,9 +402,9 @@ contains
! heap: the heap ! heap: the heap
! dir: sorting direction ! dir: sorting direction
complex(psb_dpk_), intent(inout) :: key complex(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
complex(psb_dpk_), intent(inout) :: heap(:) complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -878,9 +878,9 @@ contains
! heap: the heap ! heap: the heap
! dir: sorting direction ! dir: sorting direction
complex(psb_dpk_), intent(inout) :: key complex(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(in) :: dir integer(psb_ipk_), intent(in) :: dir
complex(psb_dpk_), intent(inout) :: heap(:) complex(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:) integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last integer(psb_ipk_), intent(inout) :: last

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

@ -139,59 +139,59 @@ contains
return return
end subroutine psb_zisort end subroutine psb_zisort
subroutine psi_zlisrx_up(n,x,idx) subroutine psi_zlisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_dpk_) :: xx complex(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) < x(j)) then if (x(j+1) < x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) >= xx) exit if (x(i) >= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_zlisrx_up end subroutine psi_zlisrx_up
subroutine psi_zlisrx_dw(n,x,idx) subroutine psi_zlisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_dpk_) :: xx complex(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) > x(j)) then if (x(j+1) > x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) <= xx) exit if (x(i) <= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_zlisrx_dw end subroutine psi_zlisrx_dw
@ -244,58 +244,58 @@ contains
enddo enddo
end subroutine psi_zlisr_dw end subroutine psi_zlisr_dw
subroutine psi_zalisrx_up(n,x,idx) subroutine psi_zalisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_dpk_) :: xx complex(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) < x(j)) then if (x(j+1) < x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) >= xx) exit if (x(i) >= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_zalisrx_up end subroutine psi_zalisrx_up
subroutine psi_zalisrx_dw(n,x,idx) subroutine psi_zalisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_dpk_) :: xx complex(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (x(j+1) > x(j)) then if (x(j+1) > x(j)) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (x(i) <= xx) exit if (x(i) <= xx) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_zalisrx_dw end subroutine psi_zalisrx_dw
@ -348,56 +348,56 @@ contains
enddo enddo
end subroutine psi_zalisr_dw end subroutine psi_zalisr_dw
subroutine psi_zaisrx_up(n,x,idx) subroutine psi_zaisrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_dpk_) :: xx complex(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then if (abs(x(j+1)) < abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit if (abs(x(i)) >= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_zaisrx_up end subroutine psi_zaisrx_up
subroutine psi_zaisrx_dw(n,x,idx) subroutine psi_zaisrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix integer(psb_ipk_) :: i,j,itx
complex(psb_dpk_) :: xx complex(psb_dpk_) :: xx
do j=n-1,1,-1 do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then if (abs(x(j+1)) > abs(x(j))) then
xx = x(j) xx = x(j)
ix = idx(j) itx = ix(j)
i=j+1 i=j+1
do do
x(i-1) = x(i) x(i-1) = x(i)
idx(i-1) = idx(i) ix(i-1) = ix(i)
i = i+1 i = i+1
if (i>n) exit if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit if (abs(x(i)) <= abs(xx)) exit
end do end do
x(i-1) = xx x(i-1) = xx
idx(i-1) = ix ix(i-1) = itx
endif endif
enddo enddo
end subroutine psi_zaisrx_dw end subroutine psi_zaisrx_dw

264
base/serial/sort/psb_z_qsort_impl.f90
Unescape Escape View File

@ -140,13 +140,13 @@ contains
end subroutine psb_zqsort end subroutine psb_zqsort
subroutine psi_zlqsrx_up(n,x,idx) subroutine psi_zlqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_dpk_) :: piv, xk, xt complex(psb_dpk_) :: piv, xk, xt
@ -179,39 +179,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -237,11 +237,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -263,14 +263,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zlisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zlisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zlisrx_up(n2,x(i:iux),idx(i:iux)) call psi_zlisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -278,30 +278,30 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zlisrx_up(n2,x(i:iux),idx(i:iux)) call psi_zlisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zlisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zlisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_zlisrx_up(n,x,idx) call psi_zlisrx_up(n,x,ix)
endif endif
end subroutine psi_zlqsrx_up end subroutine psi_zlqsrx_up
subroutine psi_zlqsrx_dw(n,x,idx) subroutine psi_zlqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_lcx_mod use psi_lcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_dpk_) :: piv, xk, xt complex(psb_dpk_) :: piv, xk, xt
@ -334,39 +334,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -392,11 +392,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -418,14 +418,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zlisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zlisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zlisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_zlisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -433,19 +433,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zlisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_zlisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zlisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zlisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_zlisrx_dw(n,x,idx) call psi_zlisrx_dw(n,x,ix)
endif endif
end subroutine psi_zlqsrx_dw end subroutine psi_zlqsrx_dw
@ -730,13 +730,13 @@ contains
end subroutine psi_zlqsr_dw end subroutine psi_zlqsr_dw
subroutine psi_zalqsrx_up(n,x,idx) subroutine psi_zalqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_dpk_) :: piv, xk, xt complex(psb_dpk_) :: piv, xk, xt
@ -769,39 +769,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(j)) then if (piv > x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(i)) then if (piv < x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -827,11 +827,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -853,14 +853,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zalisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zalisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zalisrx_up(n2,x(i:iux),idx(i:iux)) call psi_zalisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -868,29 +868,29 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zalisrx_up(n2,x(i:iux),idx(i:iux)) call psi_zalisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zalisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zalisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_zalisrx_up(n,x,idx) call psi_zalisrx_up(n,x,ix)
endif endif
end subroutine psi_zalqsrx_up end subroutine psi_zalqsrx_up
subroutine psi_zalqsrx_dw(n,x,idx) subroutine psi_zalqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
use psi_alcx_mod use psi_alcx_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
complex(psb_dpk_) :: piv, xk, xt complex(psb_dpk_) :: piv, xk, xt
@ -923,39 +923,39 @@ contains
piv = x(lpiv) piv = x(lpiv)
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv < x(j)) then if (piv < x(j)) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
if (piv > x(i)) then if (piv > x(i)) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = x(lpiv) piv = x(lpiv)
i = ilx - 1 i = ilx - 1
@ -981,11 +981,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -1007,14 +1007,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zalisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zalisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zalisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_zalisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1022,19 +1022,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zalisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_zalisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zalisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zalisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_zalisrx_dw(n,x,idx) call psi_zalisrx_dw(n,x,ix)
endif endif
end subroutine psi_zalqsrx_dw end subroutine psi_zalqsrx_dw
@ -1317,12 +1317,12 @@ contains
endif endif
end subroutine psi_zalqsr_dw end subroutine psi_zalqsr_dw
subroutine psi_zaqsrx_up(n,x,idx) subroutine psi_zaqsrx_up(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_dpk_) :: piv, xk real(psb_dpk_) :: piv, xk
@ -1356,39 +1356,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(j))) then if (piv > abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(i))) then if (piv < abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -1413,11 +1413,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_up exit outer_up
end if end if
@ -1439,14 +1439,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zaisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zaisrx_up(n2,x(i:iux),idx(i:iux)) call psi_zaisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1454,30 +1454,30 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zaisrx_up(n2,x(i:iux),idx(i:iux)) call psi_zaisrx_up(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zaisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_zaisrx_up(n,x,idx) call psi_zaisrx_up(n,x,ix)
endif endif
end subroutine psi_zaqsrx_up end subroutine psi_zaqsrx_up
subroutine psi_zaqsrx_dw(n,x,idx) subroutine psi_zaqsrx_dw(n,x,ix)
use psb_error_mod use psb_error_mod
implicit none implicit none
complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
! .. Local Scalars .. ! .. Local Scalars ..
real(psb_dpk_) :: piv, xk real(psb_dpk_) :: piv, xk
@ -1510,39 +1510,39 @@ contains
piv = abs(x(lpiv)) piv = abs(x(lpiv))
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv < abs(x(j))) then if (piv < abs(x(j))) then
xt = x(j) xt = x(j)
ixt = idx(j) ixt = ix(j)
x(j) = x(lpiv) x(j) = x(lpiv)
idx(j) = idx(lpiv) ix(j) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
if (piv > abs(x(i))) then if (piv > abs(x(i))) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
piv = abs(x(lpiv)) piv = abs(x(lpiv))
endif endif
! !
! now piv is correct; place it into first location ! now piv is correct; place it into first location
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(lpiv) x(i) = x(lpiv)
idx(i) = idx(lpiv) ix(i) = ix(lpiv)
x(lpiv) = xt x(lpiv) = xt
idx(lpiv) = ixt ix(lpiv) = ixt
i = ilx - 1 i = ilx - 1
j = iux + 1 j = iux + 1
@ -1567,11 +1567,11 @@ contains
if (j > i) then if (j > i) then
xt = x(i) xt = x(i)
ixt = idx(i) ixt = ix(i)
x(i) = x(j) x(i) = x(j)
idx(i) = idx(j) ix(i) = ix(j)
x(j) = xt x(j) = xt
idx(j) = ixt ix(j) = ixt
else else
exit outer_dw exit outer_dw
end if end if
@ -1593,14 +1593,14 @@ contains
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zaisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
if (n2 > ithrs) then if (n2 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zaisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_zaisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
else else
if (n2 > ithrs) then if (n2 > ithrs) then
@ -1608,19 +1608,19 @@ contains
istack(1,istp) = i istack(1,istp) = i
istack(2,istp) = iux istack(2,istp) = iux
else else
call psi_zaisrx_dw(n2,x(i:iux),idx(i:iux)) call psi_zaisrx_dw(n2,x(i:iux),ix(i:iux))
endif endif
if (n1 > ithrs) then if (n1 > ithrs) then
istp = istp + 1 istp = istp + 1
istack(1,istp) = ilx istack(1,istp) = ilx
istack(2,istp) = i-1 istack(2,istp) = i-1
else else
call psi_zaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) call psi_zaisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif endif
endif endif
enddo enddo
else else
call psi_zaisrx_dw(n,x,idx) call psi_zaisrx_dw(n,x,ix)
endif endif
end subroutine psi_zaqsrx_dw end subroutine psi_zaqsrx_dw

Write Preview
Loading…
Cancel
Save