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
module subroutine psi_c_heap_get_first(key,last,heap,dir,info)
implicit none
complex(psb_spk_), intent(inout) :: key
complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
module subroutine psi_d_heap_get_first(key,last,heap,dir,info)
implicit none
real(psb_dpk_), intent(inout) :: key
real(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
module subroutine psi_i_heap_get_first(key,last,heap,dir,info)
implicit none
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
module subroutine psi_s_heap_get_first(key,last,heap,dir,info)
implicit none
real(psb_spk_), intent(inout) :: key
real(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
module subroutine psi_z_heap_get_first(key,last,heap,dir,info)
implicit none
complex(psb_dpk_), intent(inout) :: key
complex(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
!
submodule (psb_c_sort_mod) psb_c_hsort_impl_mod
contains
subroutine psb_chsort(x,ix,dir,flag)
@ -402,9 +402,9 @@ contains
! heap: the heap
! dir: sorting direction
complex(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:)
complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
@ -878,9 +878,9 @@ contains
! heap: the heap
! dir: sorting direction
complex(psb_spk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(in) :: dir
complex(psb_spk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last

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

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

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

@ -42,7 +42,7 @@
! Addison-Wesley
!
submodule (psb_d_sort_mod) psb_d_hsort_impl_mod
contains
subroutine psb_dhsort(x,ix,dir,flag)
@ -295,7 +295,7 @@ contains
subroutine psi_d_heap_get_first(key,last,heap,dir,info)
implicit none
real(psb_dpk_), intent(inout) :: key
real(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
end subroutine psb_disort
subroutine psi_disrx_up(n,x,idx)
subroutine psi_disrx_up(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_disrx_up
subroutine psi_disrx_dw(n,x,idx)
subroutine psi_disrx_dw(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_disrx_dw
@ -232,56 +232,56 @@ contains
enddo
end subroutine psi_disr_dw
subroutine psi_daisrx_up(n,x,idx)
subroutine psi_daisrx_up(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_daisrx_up
subroutine psi_daisrx_dw(n,x,idx)
subroutine psi_daisrx_dw(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_daisrx_dw

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

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

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

@ -42,7 +42,7 @@
! Addison-Wesley
!
submodule (psb_i_sort_mod) psb_i_hsort_impl_mod
contains
subroutine psb_ihsort(x,ix,dir,flag)
@ -295,7 +295,7 @@ contains
subroutine psi_i_heap_get_first(key,last,heap,dir,info)
implicit none
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
end subroutine psb_iisort
subroutine psi_iisrx_up(n,x,idx)
subroutine psi_iisrx_up(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_iisrx_up
subroutine psi_iisrx_dw(n,x,idx)
subroutine psi_iisrx_dw(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_iisrx_dw
@ -232,56 +232,56 @@ contains
enddo
end subroutine psi_iisr_dw
subroutine psi_iaisrx_up(n,x,idx)
subroutine psi_iaisrx_up(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_iaisrx_up
subroutine psi_iaisrx_dw(n,x,idx)
subroutine psi_iaisrx_dw(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_iaisrx_dw

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

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

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

@ -42,7 +42,7 @@
! Addison-Wesley
!
submodule (psb_s_sort_mod) psb_s_hsort_impl_mod
contains
subroutine psb_shsort(x,ix,dir,flag)
@ -295,7 +295,7 @@ contains
subroutine psi_s_heap_get_first(key,last,heap,dir,info)
implicit none
real(psb_spk_), intent(inout) :: key
real(psb_spk_), intent(out) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
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
end subroutine psb_sisort
subroutine psi_sisrx_up(n,x,idx)
subroutine psi_sisrx_up(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_sisrx_up
subroutine psi_sisrx_dw(n,x,idx)
subroutine psi_sisrx_dw(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_sisrx_dw
@ -232,56 +232,56 @@ contains
enddo
end subroutine psi_sisr_dw
subroutine psi_saisrx_up(n,x,idx)
subroutine psi_saisrx_up(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_saisrx_up
subroutine psi_saisrx_dw(n,x,idx)
subroutine psi_saisrx_dw(n,x,ix)
use psb_error_mod
implicit none
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_) :: i,j,ix
integer(psb_ipk_) :: i,j,itx
real(psb_spk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
itx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = itx
endif
enddo
end subroutine psi_saisrx_dw

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

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

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

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

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

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

Write Preview
Loading…
Cancel
Save