fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-17 03:12:15 +00:00
Code Issues Packages Projects Releases Wiki Activity

Reworked all the sorting routines from templates.

Browse Source 
Also merged blsrch into gen_block_map_mod, where it belongs.
This commit is contained in:
Salvatore Filippone
2018-03-14 20:18:18 +00:00
parent 9ca93af839
commit b06c612f9a
14 changed files with 3214 additions and 5724 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/aux/psb_c_sort_mod.f90
+9
View File
@@ -44,6 +44,15 @@ module psb_c_sort_mod
use psb_const_mod
interface psb_msort_unique
subroutine psb_cmsort_u(x,nout,dir)
import
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_cmsort_u
end interface psb_msort_unique
type psb_c_heap
integer(psb_ipk_) :: last, dir
complex(psb_spk_), allocatable :: keys(:)
base/modules/aux/psb_d_sort_mod.f90
+29
View File
@@ -44,6 +44,15 @@ module psb_d_sort_mod
use psb_const_mod
interface psb_msort_unique
subroutine psb_dmsort_u(x,nout,dir)
import
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_dmsort_u
end interface psb_msort_unique
type psb_d_heap
integer(psb_ipk_) :: last, dir
real(psb_dpk_), allocatable :: keys(:)
@@ -79,6 +88,26 @@ module psb_d_sort_mod
end subroutine psb_dmsort
end interface psb_msort
interface psb_bsrch
function psb_dbsrch(key,n,v) result(ipos)
import
integer(psb_ipk_) :: ipos, n
real(psb_dpk_) :: key
real(psb_dpk_) :: v(:)
end function psb_dbsrch
end interface psb_bsrch
interface psb_ssrch
function psb_dssrch(key,n,v) result(ipos)
import
implicit none
integer(psb_ipk_) :: ipos, n
real(psb_dpk_) :: key
real(psb_dpk_) :: v(:)
end function psb_dssrch
end interface psb_ssrch
interface
subroutine psi_d_msort_up(n,k,l,iret)
import
base/modules/aux/psb_i_sort_mod.f90
+22 -25
View File
@@ -43,30 +43,6 @@
module psb_i_sort_mod
use psb_const_mod
interface psb_iblsrch
function psb_iblsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_iblsrch
end interface psb_iblsrch
interface psb_ibsrch
function psb_ibsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_ibsrch
end interface psb_ibsrch
interface psb_issrch
function psb_issrch(key,n,v) result(ipos)
import :: psb_ipk_
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
end function psb_issrch
end interface psb_issrch
interface psb_isaperm
logical function psb_isaperm(n,eip)
@@ -76,9 +52,10 @@ module psb_i_sort_mod
end function psb_isaperm
end interface psb_isaperm
interface psb_msort_unique
subroutine psb_imsort_u(x,nout,dir)
import :: psb_ipk_, psb_spk_, psb_dpk_
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
@@ -120,6 +97,26 @@ module psb_i_sort_mod
end subroutine psb_imsort
end interface psb_msort
interface psb_bsrch
function psb_ibsrch(key,n,v) result(ipos)
import
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
end function psb_ibsrch
end interface psb_bsrch
interface psb_ssrch
function psb_issrch(key,n,v) result(ipos)
import
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
end function psb_issrch
end interface psb_ssrch
interface
subroutine psi_i_msort_up(n,k,l,iret)
import
base/modules/aux/psb_s_sort_mod.f90
+29
View File
@@ -44,6 +44,15 @@ module psb_s_sort_mod
use psb_const_mod
interface psb_msort_unique
subroutine psb_smsort_u(x,nout,dir)
import
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_smsort_u
end interface psb_msort_unique
type psb_s_heap
integer(psb_ipk_) :: last, dir
real(psb_spk_), allocatable :: keys(:)
@@ -79,6 +88,26 @@ module psb_s_sort_mod
end subroutine psb_smsort
end interface psb_msort
interface psb_bsrch
function psb_sbsrch(key,n,v) result(ipos)
import
integer(psb_ipk_) :: ipos, n
real(psb_spk_) :: key
real(psb_spk_) :: v(:)
end function psb_sbsrch
end interface psb_bsrch
interface psb_ssrch
function psb_sssrch(key,n,v) result(ipos)
import
implicit none
integer(psb_ipk_) :: ipos, n
real(psb_spk_) :: key
real(psb_spk_) :: v(:)
end function psb_sssrch
end interface psb_ssrch
interface
subroutine psi_s_msort_up(n,k,l,iret)
import
base/modules/aux/psb_z_sort_mod.f90
+9
View File
@@ -44,6 +44,15 @@ module psb_z_sort_mod
use psb_const_mod
interface psb_msort_unique
subroutine psb_zmsort_u(x,nout,dir)
import
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_zmsort_u
end interface psb_msort_unique
type psb_z_heap
integer(psb_ipk_) :: last, dir
complex(psb_dpk_), allocatable :: keys(:)
base/modules/desc/psb_gen_block_map_mod.f90
+46 -49
View File
@@ -90,7 +90,8 @@ module psb_gen_block_map_mod
& block_get_fmt, block_l2gs1, block_l2gs2, block_l2gv1,&
& block_l2gv2, block_g2ls1, block_g2ls2, block_g2lv1,&
& block_g2lv2, block_g2ls1_ins, block_g2ls2_ins,&
& block_g2lv1_ins, block_g2lv2_ins, block_clone, block_reinit
& block_g2lv1_ins, block_g2lv2_ins, block_clone, block_reinit,&
& gen_block_search
integer(psb_ipk_), private :: laddsz=500
@@ -992,7 +993,6 @@ contains
subroutine block_fnd_owner(idx,iprc,idxmap,info)
use psb_penv_mod
use psb_sort_mod
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
@@ -1009,7 +1009,7 @@ contains
return
end if
do i=1, nv
ip = psb_iblsrch(idx(i)-1,np+1,idxmap%vnl)
ip = gen_block_search(idx(i)-1,np+1,idxmap%vnl)
iprc(i) = ip - 1
end do
@@ -1226,52 +1226,49 @@ contains
return
end subroutine block_reinit
!!$
!!$ subroutine block_reinit(idxmap,info)
!!$ use psb_penv_mod
!!$ use psb_error_mod
!!$ use psb_realloc_mod
!!$ implicit none
!!$ class(psb_gen_block_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: err_act, nr,nc,k, nl, ictxt
!!$ integer(psb_ipk_), allocatable :: idx(:),lidx(:)
!!$ character(len=20) :: name='block_reinit'
!!$ logical, parameter :: debug=.false.
!!$
!!$ info = psb_success_
!!$ call psb_get_erraction(err_act)
!!$ ictxt = idxmap%get_ctxt()
!!$ nr = idxmap%get_lr()
!!$ nc = idxmap%get_lc()
!!$ if (nc>nr) then
!!$ lidx = (/(k,k=nr+1,nc)/)
!!$ idx = (/(k,k=nr+1,nc)/)
!!$ call idxmap%l2gip(idx,info)
!!$ end if
!!$ if (info /= 0) &
!!$ & write(0,*) 'From l2gip',info
!!$
!!$ call idxmap%init(ictxt,nr,info)
!!$ if (nc>nr) then
!!$ call idxmap%g2lip_ins(idx,info,lidx=lidx)
!!$ end if
!!$
!!$
!!$ if (info /= psb_success_) then
!!$ info = psb_err_from_subroutine_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$
!!$9999 call psb_error_handler(err_act)
!!$
!!$ return
!!$ end subroutine block_reinit
!!$
!
! This is a purely internal version of "binary" search
! specialized for gen_block usage.
!
function gen_block_search(key,n,v) result(ipos)
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m
if (n < 5) then
! don't bother with binary search for very
! small vectors
ipos = 0
do
if (ipos == n) return
if (key < v(ipos+1)) return
ipos = ipos + 1
end do
else
lb = 1
ub = n
ipos = -1
do while (lb <= ub)
m = (lb+ub)/2
if (key==v(m)) then
ipos = m
return
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (v(ub) > key) then
ub = ub - 1
end if
ipos = ub
endif
return
end function gen_block_search
end module psb_gen_block_map_mod
base/modules/desc/psb_hash_map_mod.f90
+8 -1
View File
@@ -134,6 +134,8 @@ contains
& val = val + size(idxmap%hashv)*psb_sizeof_int
if (allocated(idxmap%glb_lc)) &
& val = val + size(idxmap%glb_lc)*psb_sizeof_int
if (allocated(idxmap%loc_to_glob)) &
& val = val + size(idxmap%loc_to_glob)*psb_sizeof_int
val = val + psb_sizeof(idxmap%hash)
end function hash_sizeof
@@ -743,6 +745,9 @@ contains
end subroutine hash_g2lv2_ins
!
! init from VL, with checks on input.
!
subroutine hash_init_vl(idxmap,ictxt,vl,info)
use psb_penv_mod
use psb_error_mod
@@ -870,7 +875,9 @@ contains
end subroutine hash_init_vg
!
! init from VL, with no checks on input
!
subroutine hash_init_vlu(idxmap,ictxt,ntot,nl,vlu,info)
use psb_penv_mod
use psb_error_mod
base/serial/sort/psb_c_msort_impl.f90
+35
View File
@@ -41,6 +41,41 @@
! Addison-Wesley
!
subroutine psb_cmsort_u(x,nout,dir)
use psb_c_sort_mod, psb_protect_name => psb_cmsort_u
use psb_error_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_ipk_) :: n, k
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
n = size(x)
call psb_msort(x,dir=dir)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_cmsort_u
base/serial/sort/psb_d_msort_impl.f90
+93
View File
@@ -41,6 +41,99 @@
! Addison-Wesley
!
subroutine psb_dmsort_u(x,nout,dir)
use psb_d_sort_mod, psb_protect_name => psb_dmsort_u
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_ipk_) :: n, k
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
n = size(x)
call psb_msort(x,dir=dir)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_dmsort_u
function psb_dbsrch(key,n,v) result(ipos)
use psb_d_sort_mod, psb_protect_name => psb_dbsrch
implicit none
integer(psb_ipk_) :: ipos, n
real(psb_dpk_) :: key
real(psb_dpk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m, i
ipos = -1
if (n<5) then
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end if
lb = 1
ub = n
do while (lb.le.ub)
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
lb = ub + 1
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end function psb_dbsrch
function psb_dssrch(key,n,v) result(ipos)
use psb_d_sort_mod, psb_protect_name => psb_dssrch
implicit none
integer(psb_ipk_) :: ipos, n
real(psb_dpk_) :: key
real(psb_dpk_) :: v(:)
integer(psb_ipk_) :: i
ipos = -1
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end function psb_dssrch
subroutine psb_dmsort(x,ix,dir,flag)
use psb_d_sort_mod, psb_protect_name => psb_dmsort
use psb_error_mod
base/serial/sort/psb_i_msort_impl.f90
+48 -91
View File
@@ -95,59 +95,65 @@
return
end function psb_isaperm
function psb_iblsrch(key,n,v) result(ipos)
use psb_i_sort_mod, psb_protect_name => psb_iblsrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m
subroutine psb_imsort_u(x,nout,dir)
use psb_i_sort_mod, psb_protect_name => psb_imsort_u
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
if (n < 5) then
! don't bother with binary search for very
! small vectors
ipos = 0
do
if (ipos == n) return
if (key < v(ipos+1)) return
ipos = ipos + 1
end do
else
lb = 1
ub = n
ipos = -1
integer(psb_ipk_) :: n, k
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
n = size(x)
call psb_msort(x,dir=dir)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
do while (lb <= ub)
m = (lb+ub)/2
if (key==v(m)) then
ipos = m
return
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
if (v(ub) > key) then
!!$ write(0,*) 'Check: ',ub,v(ub),key
ub = ub - 1
end if
ipos = ub
endif
return
end function psb_iblsrch
9999 call psb_error_handler(err_act)
return
end subroutine psb_imsort_u
function psb_ibsrch(key,n,v) result(ipos)
use psb_i_sort_mod, psb_protect_name => psb_ibsrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m
integer(psb_ipk_) :: lb, ub, m, i
ipos = -1
if (n<5) then
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end if
lb = 1
ub = n
ipos = -1
do while (lb.le.ub)
m = (lb+ub)/2
@@ -166,7 +172,8 @@
function psb_issrch(key,n,v) result(ipos)
use psb_i_sort_mod, psb_protect_name => psb_issrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: i
@@ -182,56 +189,6 @@
return
end function psb_issrch
subroutine psb_imsort_u(x,nout,dir)
use psb_i_sort_mod, psb_protect_name => psb_imsort_u
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_ipk_) :: dir_, n, err_act, k
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
call psb_imsort(x,dir=dir_)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_imsort_u
subroutine psb_imsort(x,ix,dir,flag)
use psb_i_sort_mod, psb_protect_name => psb_imsort
use psb_error_mod
base/serial/sort/psb_s_msort_impl.f90
+93
View File
@@ -41,6 +41,99 @@
! Addison-Wesley
!
subroutine psb_smsort_u(x,nout,dir)
use psb_s_sort_mod, psb_protect_name => psb_smsort_u
use psb_error_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_ipk_) :: n, k
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
n = size(x)
call psb_msort(x,dir=dir)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_smsort_u
function psb_sbsrch(key,n,v) result(ipos)
use psb_s_sort_mod, psb_protect_name => psb_sbsrch
implicit none
integer(psb_ipk_) :: ipos, n
real(psb_spk_) :: key
real(psb_spk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m, i
ipos = -1
if (n<5) then
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end if
lb = 1
ub = n
do while (lb.le.ub)
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
lb = ub + 1
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end function psb_sbsrch
function psb_sssrch(key,n,v) result(ipos)
use psb_s_sort_mod, psb_protect_name => psb_sssrch
implicit none
integer(psb_ipk_) :: ipos, n
real(psb_spk_) :: key
real(psb_spk_) :: v(:)
integer(psb_ipk_) :: i
ipos = -1
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end function psb_sssrch
subroutine psb_smsort(x,ix,dir,flag)
use psb_s_sort_mod, psb_protect_name => psb_smsort
use psb_error_mod
base/serial/sort/psb_z_msort_impl.f90
+35
View File
@@ -41,6 +41,41 @@
! Addison-Wesley
!
subroutine psb_zmsort_u(x,nout,dir)
use psb_z_sort_mod, psb_protect_name => psb_zmsort_u
use psb_error_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_ipk_) :: n, k
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
n = size(x)
call psb_msort(x,dir=dir)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_zmsort_u
configure
Vendored
+2757 -5557
View File
File diff suppressed because it is too large Load Diff
configure.ac
+1 -1
View File
@@ -393,7 +393,7 @@ if test "X$FCOPT" == "X" ; then
# other compilers ..
FCOPT="-fast $FCOPT"
elif test "X$psblas_cv_fc" == X"cray" ; then
FCOPT="-O3 -em $FCOPT"
FCOPT="-O3 -em -J. $FCOPT"
elif test "X$psblas_cv_fc" == X"nag" ; then
# NAG compiler ..
FCOPT="-O2 "