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

psblas3:

Browse Source 
base/serial/aux/Makefile
 base/serial/aux/cacmp_mod.f90
 base/serial/aux/calcmp_mod.f90
 base/serial/aux/calsr.f90
 base/serial/aux/calsrx.f90
 base/serial/aux/camsort_dw.f90
 base/serial/aux/camsort_up.f90
 base/serial/aux/camsr.f90
 base/serial/aux/camsrx.f90
 base/serial/aux/casr.f90
 base/serial/aux/casrx.f90
 base/serial/aux/clcmp_mod.f90
 base/serial/aux/clsr.f90
 base/serial/aux/clsrx.f90
 base/serial/aux/damsort_dw.f90
 base/serial/aux/damsort_up.f90
 base/serial/aux/dasr.f90
 base/serial/aux/dasrx.f90
 base/serial/aux/dmsort_dw.f90
 base/serial/aux/dmsort_up.f90
 base/serial/aux/dmsr.f90
 base/serial/aux/dmsrx.f90
 base/serial/aux/dsr.f90
 base/serial/aux/dsrx.f90
 base/serial/aux/iamsort_dw.f90
 base/serial/aux/iamsort_up.f90
 base/serial/aux/iasr.f90
 base/serial/aux/iasrx.f90
 base/serial/aux/ibsrch.f
 base/serial/aux/idot.f90
 base/serial/aux/imsr.f90
 base/serial/aux/imsru.f90
 base/serial/aux/imsrx.f90
 base/serial/aux/inrm2.f90
 base/serial/aux/isaperm.f
 base/serial/aux/isr.f90
 base/serial/aux/isrx.f90
 base/serial/aux/issrch.f
 base/serial/aux/msort_dw.f90
 base/serial/aux/msort_up.f90
 base/serial/aux/samsort_dw.f90
 base/serial/aux/samsort_up.f90
 base/serial/aux/sasr.f90
 base/serial/aux/sasrx.f90
 base/serial/aux/smsort_dw.f90
 base/serial/aux/smsort_up.f90
 base/serial/aux/smsr.f90
 base/serial/aux/smsrx.f90
 base/serial/aux/ssr.f90
 base/serial/aux/ssrx.f90
 base/serial/aux/zacmp_mod.f90
 base/serial/aux/zalcmp_mod.f90
 base/serial/aux/zalsr.f90
 base/serial/aux/zalsrx.f90
 base/serial/aux/zamsort_dw.f90
 base/serial/aux/zamsort_up.f90
 base/serial/aux/zamsr.f90
 base/serial/aux/zamsrx.f90
 base/serial/aux/zasr.f90
 base/serial/aux/zasrx.f90
 base/serial/aux/zlcmp_mod.f90
 base/serial/aux/zlsr.f90
 base/serial/aux/zlsrx.f90

Remove old sort internals, step 1.
psblas-3.4-maint
Salvatore Filippone 11 years ago
parent 0c0c96b142
commit ff86462e75
63 changed files with 0 additions and 13794 deletions
Show Stats Download Patch File Download Diff File

52
base/serial/aux/Makefile
Unescape Escape View File

@ -1,52 +0,0 @@
include ../../../Make.inc
#
# The object files
#
FOBJS = idot.o inrm2.o
# FOBJS = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\
# imsr.o imsrx.o imsru.o iamsort_up.o iamsort_dw.o idot.o inrm2.o\
# dsr.o dsrx.o dasr.o dasrx.o dmsr.o dmsrx.o \
# dmsort_up.o dmsort_dw.o damsort_up.o damsort_dw.o \
# ssr.o ssrx.o sasr.o sasrx.o smsr.o smsrx.o \
# smsort_up.o smsort_dw.o samsort_up.o samsort_dw.o \
# clcmp_mod.o clsr.o clsrx.o \
# calcmp_mod.o calsr.o calsrx.o \
# cacmp_mod.o casr.o casrx.o camsr.o camsrx.o camsort_up.o camsort_dw.o\
# zlcmp_mod.o zlsr.o zlsrx.o \
# zalcmp_mod.o zalsr.o zalsrx.o \
# zacmp_mod.o zasr.o zasrx.o zamsr.o zamsrx.o zamsort_up.o zamsort_dw.o
OBJS=$(FOBJS)
#
# Where the library should go, and how it is called.
#
LIBDIR=../..
INCDIR=../..
MODDIR=../../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
#
# No change should be needed below
#
default: lib
lib: $(OBJS)
$(AR) $(LIBDIR)/$(LIBNAME) $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
clsr.o clsrx.o: clcmp_mod.o
calsr.o calsrx.o: calcmp_mod.o
camsort_up.o camsort_dw.o casr.o casrx.o: cacmp_mod.o
zlsr.o zlsrx.o: zlcmp_mod.o
zalsr.o zalsrx.o: zalcmp_mod.o
zamsort_up.o zamsort_dw.o zasr.o zasrx.o: zacmp_mod.o
clean:
/bin/rm -f $(OBJS) *$(.mod)
veryclean: clean

80
base/serial/aux/cacmp_mod.f90
Unescape Escape View File

@ -1,80 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module cacmp_mod
use psb_const_mod
interface operator(<)
module procedure calt
end interface
interface operator(<=)
module procedure cale
end interface
interface operator(>)
module procedure cagt
end interface
interface operator(>=)
module procedure cage
end interface
contains
function calt(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: calt
calt = (abs(a) < abs(b))
end function calt
function cale(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: cale
cale = (abs(a) <= abs(b))
end function cale
function cagt(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: cagt
cagt = (abs(a) > abs(b))
end function cagt
function cage(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: cage
cage = (abs(a) >= abs(b))
end function cage
end module cacmp_mod

84
base/serial/aux/calcmp_mod.f90
Unescape Escape View File

@ -1,84 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module calcmp_mod
use psb_const_mod
interface operator(<)
module procedure callt
end interface
interface operator(<=)
module procedure calle
end interface
interface operator(>)
module procedure calgt
end interface
interface operator(>=)
module procedure calge
end interface
contains
function callt(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: callt
callt = (abs(real(a))<abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))<abs(aimag(b))))
end function callt
function calle(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: calle
calle = (abs(real(a))<abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))<=abs(aimag(b))))
end function calle
function calgt(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: calgt
calgt = (abs(real(a))>abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>abs(aimag(b))))
end function calgt
function calge(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: calge
calge = (abs(real(a))>abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b))))
end function calge
end module calcmp_mod

362
base/serial/aux/calsr.f90
Unescape Escape View File

@ -1,362 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine calsr(n,x,dir)
use psb_serial_mod
use calcmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
complex(psb_spk_) :: x(n)
! ..
! .. Local Scalars ..
complex(psb_spk_) :: xk, piv, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='calsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call icalsr_up(n,x)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='calsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call icalsr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='calsr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine icalsr_up(n,x)
use calcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine icalsr_up
subroutine icalsr_dw(n,x)
use calcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine icalsr_dw
end subroutine calsr

414
base/serial/aux/calsrx.f90
Unescape Escape View File

@ -1,414 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine calsrx(n,x,indx,dir,flag)
use psb_serial_mod
use calcmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
complex(psb_spk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call icalsrx_up(n,x,indx)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icalsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call icalsrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine icalsrx_up(n,x,indx)
use calcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine icalsrx_up
subroutine icalsrx_dw(n,x,indx)
use calcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine icalsrx_dw
end subroutine calsrx

173
base/serial/aux/camsort_dw.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - real(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine camsort_dw(n,k,l,iret)
use cacmp_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine camsort_dw

173
base/serial/aux/camsort_up.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine camsort_up(n,k,l,iret)
use cacmp_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_spk_) k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine camsort_up

75
base/serial/aux/camsr.f90
Unescape Escape View File

@ -1,75 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsr.f90
! Subroutine:
! Parameters:
subroutine camsr(n,x,idir)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n, idir
complex(psb_spk_) :: x(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: lswap, iret, info, lp, k
complex(psb_spk_) :: swap
if (n<0) then
return
endif
if (n<=1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='camsr')
call psb_error()
endif
if (idir == psb_asort_up_) then
call camsort_up(n,x,iaux,iret)
else
call camsort_dw(n,x,iaux,iret)
end if
if (iret == 0) call psb_ip_reord(n,x,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='camsr')
call psb_error()
endif
return
end subroutine camsr

82
base/serial/aux/camsrx.f90
Unescape Escape View File

@ -1,82 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsrx.f90
! Subroutine:
! Parameters:
subroutine camsrx(n,x,indx,idir,flag)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n,idir,flag
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, lp, k,lswap, ixswap
complex(psb_spk_) :: swap
if (n<0) then
return
endif
if (n == 0) return
if (flag == psb_sort_ovw_idx_) then
do k=1,n
indx(k) = k
enddo
end if
if (n == 1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='camsrx')
call psb_error()
endif
if (idir == psb_asort_up_) then
call camsort_up(n,x,iaux,iret)
else
call camsort_dw(n,x,iaux,iret)
end if
if (iret == 0) call psb_ip_reord(n,x,indx,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='camsrx')
call psb_error()
endif
return
end subroutine camsrx

362
base/serial/aux/casr.f90
Unescape Escape View File

@ -1,362 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine casr(n,x,dir)
use psb_serial_mod
use cacmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
complex(psb_spk_) :: x(n)
! ..
! .. Local Scalars ..
complex(psb_spk_) :: xk, piv, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='casr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call icasr_up(n,x)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='casr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call icasr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='casr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine icasr_up(n,x)
use cacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine icasr_up
subroutine icasr_dw(n,x)
use cacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine icasr_dw
end subroutine casr

414
base/serial/aux/casrx.f90
Unescape Escape View File

@ -1,414 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine casrx(n,x,indx,dir,flag)
use psb_serial_mod
use cacmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
complex(psb_spk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call icasrx_up(n,x,indx)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call icasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call icasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call icasrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine icasrx_up(n,x,indx)
use cacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine icasrx_up
subroutine icasrx_dw(n,x,indx)
use cacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine icasrx_dw
end subroutine casrx

80
base/serial/aux/clcmp_mod.f90
Unescape Escape View File

@ -1,80 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module clcmp_mod
use psb_const_mod
interface operator(<)
module procedure cllt
end interface
interface operator(<=)
module procedure clle
end interface
interface operator(>)
module procedure clgt
end interface
interface operator(>=)
module procedure clge
end interface
contains
function cllt(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: cllt
cllt = (real(a)<real(b)).or.((real(a) == real(b)).and.(aimag(a)<aimag(b)))
end function cllt
function clle(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: clle
clle = (real(a)<real(b)).or.((real(a) == real(b)).and.(aimag(a)<=aimag(b)))
end function clle
function clgt(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: clgt
clgt = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>aimag(b)))
end function clgt
function clge(a,b)
use psb_const_mod
complex(psb_spk_), intent(in) :: a,b
logical :: clge
clge = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>=aimag(b)))
end function clge
end module clcmp_mod

362
base/serial/aux/clsr.f90
Unescape Escape View File

@ -1,362 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine clsr(n,x,dir)
use psb_serial_mod
use clcmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
complex(psb_spk_) :: x(n)
! ..
! .. Local Scalars ..
complex(psb_spk_) :: xk, piv, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_lsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='clsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call iclsr_up(n,x)
endif
case(psb_lsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='clsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call iclsr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='clsr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine iclsr_up(n,x)
use clcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iclsr_up
subroutine iclsr_dw(n,x)
use clcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iclsr_dw
end subroutine clsr

414
base/serial/aux/clsrx.f90
Unescape Escape View File

@ -1,414 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine clsrx(n,x,indx,dir,flag)
use psb_serial_mod
use clcmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
complex(psb_spk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_lsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iclsrx_up(n,x,indx)
endif
case(psb_lsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iclsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iclsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iclsrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine iclsrx_up(n,x,indx)
use clcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iclsrx_up
subroutine iclsrx_dw(n,x,indx)
use clcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iclsrx_dw
end subroutine clsrx

173
base/serial/aux/damsort_dw.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - real(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine damsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine damsort_dw

173
base/serial/aux/damsort_up.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine damsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine damsort_up

361
base/serial/aux/dasr.f90
Unescape Escape View File

@ -1,361 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dasr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
real(psb_dpk_) :: x(n)
! ..
! .. Local Scalars ..
real(psb_dpk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_up(n,x)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='dasr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine disr_up(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_up
subroutine disr_dw(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_dw
end subroutine dasr

409
base/serial/aux/dasrx.f90
Unescape Escape View File

@ -1,409 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dasrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
real(psb_dpk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
write(psb_err_unit,*) 'Error in isrx: invalid flag',flag
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idasrx_up(n,x,indx)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idasrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='dasrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine idasrx_up(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idasrx_up
subroutine idasrx_dw(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idasrx_dw
end subroutine dasrx

173
base/serial/aux/dmsort_dw.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - real(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine dmsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine dmsort_dw

173
base/serial/aux/dmsort_up.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine dmsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_dpk_) k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine dmsort_up

81
base/serial/aux/dmsr.f90
Unescape Escape View File

@ -1,81 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsr.f90
! Subroutine:
! Parameters:
subroutine dmsr(n,x,idir)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n, idir
real(psb_dpk_) :: x(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: lswap, iret, info, lp, k
real(psb_dpk_) :: swap
if (n<0) then
!!$ write(psb_err_unit,*) 'Error: IMSR: N<0'
return
endif
if (n<=1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsr')
call psb_error()
endif
select case(idir)
case (psb_sort_up_)
call dmsort_up(n,x,iaux,iret)
case (psb_asort_up_)
call damsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call damsort_dw(n,x,iaux,iret)
case (psb_sort_down_)
call dmsort_dw(n,x,iaux,iret)
end select
if (iret == 0) call psb_ip_reord(n,x,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsr')
call psb_error()
endif
return
end subroutine dmsr

88
base/serial/aux/dmsrx.f90
Unescape Escape View File

@ -1,88 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsrx.f90
! Subroutine:
! Parameters:
subroutine dmsrx(n,x,indx,idir,flag)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n,idir,flag
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, lp, k,lswap, ixswap
real(psb_dpk_) :: swap
if (n<0) then
!!$ write(psb_err_unit,*) 'Error: DMSRX: N<0'
return
endif
if (n == 0) return
if (flag == psb_sort_ovw_idx_) then
do k=1,n
indx(k) = k
enddo
end if
if (n == 1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsrx')
call psb_error()
endif
select case(idir)
case (psb_sort_up_)
call dmsort_up(n,x,iaux,iret)
case (psb_asort_up_)
call damsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call damsort_dw(n,x,iaux,iret)
case (psb_sort_down_)
call dmsort_dw(n,x,iaux,iret)
end select
if (iret == 0) call psb_ip_reord(n,x,indx,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsrx')
call psb_error()
endif
return
end subroutine dmsrx

359
base/serial/aux/dsr.f90
Unescape Escape View File

@ -1,359 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dsr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
real(psb_dpk_) :: x(n)
! ..
! .. Local Scalars ..
real(psb_dpk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_up(n,x)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='dsr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine disr_up(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_up
subroutine disr_dw(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_dw
end subroutine dsr

410
base/serial/aux/dsrx.f90
Unescape Escape View File

@ -1,410 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dsrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
real(psb_dpk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idsrx_up(n,x,indx)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='dsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idsrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='dsrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine idsrx_up(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idsrx_up
subroutine idsrx_dw(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idsrx_dw
end subroutine dsrx

173
base/serial/aux/iamsort_dw.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - real(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine iamsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine iamsort_dw

173
base/serial/aux/iamsort_up.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine iamsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine iamsort_up

361
base/serial/aux/iasr.f90
Unescape Escape View File

@ -1,361 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine iasr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
integer(psb_ipk_) :: x(n)
! ..
! .. Local Scalars ..
integer(psb_ipk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='iasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call iaisr_up(n,x)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='iasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call iaisr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='iasr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine iaisr_up(n,x)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iaisr_up
subroutine iaisr_dw(n,x)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iaisr_dw
end subroutine iasr

410
base/serial/aux/iasrx.f90
Unescape Escape View File

@ -1,410 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine iasrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
integer(psb_ipk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iiasrx_up(n,x,indx)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iiasrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine iiasrx_up(n,x,indx)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iiasrx_up
subroutine iiasrx_dw(n,x,indx)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iiasrx_dw
end subroutine iasrx

58
base/serial/aux/ibsrch.f
Unescape Escape View File

@ -1,58 +0,0 @@
C
C Parallel Sparse BLAS version 3.4
C (C) Copyright 2006, 2010, 2015
C Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari CNRS-IRIT, Toulouse
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
subroutine ibsrch(ipos,key,n,v)
use psb_serial_mod
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: lb, ub, m
lb = 1
ub = n
ipos = -1
do while (lb.le.ub)
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
lb = ub + 1
else if (key.lt.v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end

58
base/serial/aux/idot.f90
Unescape Escape View File

@ -1,58 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
! idot.f90
!
! A function formally similar to DDOT but on integers.
! Defined just to have a preprocessed version of vectors.
!
function idot(n,x,incx,y,incy) result(res)
use psb_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: n,incx,incy
integer(psb_ipk_), intent(in) :: x(*), y(*)
integer(psb_ipk_) :: res
integer(psb_ipk_) :: i, ix, iy
res = izero
if ((n<1).or.(incx<1).or.(incy<1)) return
ix = 1
iy = 1
do i=1,n
res = res + x(ix)*y(iy)
ix=ix+incx
iy=iy+incy
end do
end function idot

80
base/serial/aux/imsr.f90
Unescape Escape View File

@ -1,80 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsr.f90
! Subroutine:
! Parameters:
subroutine imsr(n,x,idir)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n, idir
integer(psb_ipk_) :: x(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iswap, iret, info, lp, k
integer(psb_ipk_) :: lswap
if (n<0) then
return
endif
if (n<=1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='imsr')
call psb_error()
endif
select case(idir)
case (psb_sort_up_)
call msort_up(n,x,iaux,iret)
case (psb_asort_up_)
call iamsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call iamsort_dw(n,x,iaux,iret)
case (psb_sort_down_)
call msort_dw(n,x,iaux,iret)
end select
if (iret == 0) call psb_ip_reord(n,x,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='imsr')
call psb_error()
endif
return
end subroutine imsr

64
base/serial/aux/imsru.f90
Unescape Escape View File

@ -1,64 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsru.f90
! Subroutine:
! Parameters:
subroutine imsru(n,x,idir,nout)
use psb_serial_mod
implicit none
integer(psb_ipk_) :: n, idir,nout
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: k
nout = 0
if (n<0) then
return
endif
if (n<=1) then
nout = n
return
endif
call imsr(n,x,idir)
nout = 1
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
end subroutine imsru

88
base/serial/aux/imsrx.f90
Unescape Escape View File

@ -1,88 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsrx.f90
! Subroutine:
! Parameters:
subroutine imsrx(n,x,indx,idir,flag)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n,idir,flag
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iswap, iret, info, lp, k
integer(psb_ipk_) :: lswap, ixswap
if (n<0) then
return
endif
if (n == 0) return
if (flag == psb_sort_ovw_idx_) then
do k=1,n
indx(k) = k
enddo
end if
if (n == 1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='imsrx')
call psb_error()
endif
select case(idir)
case (psb_sort_up_)
call msort_up(n,x,iaux,iret)
case (psb_asort_up_)
call iamsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call iamsort_dw(n,x,iaux,iret)
case (psb_sort_down_)
call msort_dw(n,x,iaux,iret)
end select
if (iret == 0) call psb_ip_reord(n,x,indx,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='imsrx')
call psb_error()
endif
return
end subroutine imsrx

58
base/serial/aux/inrm2.f90
Unescape Escape View File

@ -1,58 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
! inrm2.f90
!
! A function formally similar to DNRM2 but on integers.
! Defined just to have a preprocessed version of vectors.
! Does it make sense?? Better change it to ABS, i.e. nrm1.
!
!
function inrm2(n,x,incx) result(res)
use psb_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: n,incx
integer(psb_ipk_), intent(in) :: x(*)
integer(psb_ipk_) :: res
integer(psb_ipk_) :: i, ix, iy
res = izero
if ((n<1).or.(incx<1)) return
ix = 1
do i=1,n
res = res + abs(x(ix))
ix=ix+incx
end do
end function inrm2

104
base/serial/aux/isaperm.f
Unescape Escape View File

@ -1,104 +0,0 @@
C
C Parallel Sparse BLAS version 3.4
C (C) Copyright 2006, 2010, 2015
C Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari CNRS-IRIT, Toulouse
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
***********************************************************************
* *
* REFERENCES = *
* *
* [1] D. E. Knuth *
* The art of computer programming Vol. 1 *
* Sect. 1.3.3 *
* Addison-Wesley *
* *
* *
* FUNCTION: Checks whether a vector really is a permutation *
* works by exploiting the cycle structure of the *
* permutation. *
* *
* *
***********************************************************************
LOGICAL FUNCTION ISAPERM(N,IP)
use psb_serial_mod
implicit none
C .. Scalar Arguments ..
integer(psb_ipk_) :: n
c ..
c .. array arguments ..
integer(psb_ipk_) :: ip(n)
c ..
c .. local scalars ..
integer(psb_ipk_) :: i,J,M
C ..
ISAPERM = .TRUE.
C
C Sanity check first
C
DO I=1, N
IF ((IP(I).LT.1).OR.(IP(I).GT.N)) THEN
ISAPERM = .FALSE.
RETURN
ENDIF
ENDDO
C
C Now work through the cycles, by marking each successive item as negative.
C No cycle should intersect with any other, hence the .GE.1 check.
C
DO M = 1, N
I = IP(M)
IF (I.LT.0) THEN
IP(M) = -I
ELSE IF (I.NE.M) THEN
J = IP(I)
IP(I) = -J
I = J
DO WHILE ((J.GE.1).AND.(J.NE.M))
J = IP(I)
IP(I) = -J
I = J
ENDDO
IP(M) = IABS(IP(M))
IF (J.NE.M) THEN
ISAPERM = .FALSE.
DO I=1, N
IP(I) = IABS(IP(I))
ENDDO
GOTO 9999
ENDIF
END IF
ENDDO
9999 CONTINUE
RETURN
END

360
base/serial/aux/isr.f90
Unescape Escape View File

@ -1,360 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine isr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
integer(psb_ipk_) :: x(n)
! ..
! .. Local Scalars ..
integer(psb_ipk_) :: xk, piv, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='isr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call iisr_up(n,x)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='isr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call iisr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='isr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine iisr_up(n,x)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iisr_up
subroutine iisr_dw(n,x)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iisr_dw
end subroutine isr

410
base/serial/aux/isrx.f90
Unescape Escape View File

@ -1,410 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine isrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
integer(psb_ipk_) :: x(n), indx(n)
! ..
! .. Local Scalars ..
integer(psb_ipk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iisrx_up(n,x,indx)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iisrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iisrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine iisrx_up(n,x,indx)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iisrx_up
subroutine iisrx_dw(n,x,indx)
implicit none
integer(psb_ipk_) :: n
integer(psb_ipk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iisrx_dw
end subroutine isrx

51
base/serial/aux/issrch.f
Unescape Escape View File

@ -1,51 +0,0 @@
C
C Parallel Sparse BLAS version 3.4
C (C) Copyright 2006, 2010, 2015
C Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari CNRS-IRIT, Toulouse
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
subroutine issrch(ipos,key,n,v)
use psb_serial_mod
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: i
ipos = -1
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end

172
base/serial/aux/msort_dw.f90
Unescape Escape View File

@ -1,172 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine msort_dw(n,k,l,iret)
use psb_serial_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n),l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine msort_dw

172
base/serial/aux/msort_up.f90
Unescape Escape View File

@ -1,172 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine msort_up(n,k,l,iret)
use psb_serial_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n),l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine msort_up

173
base/serial/aux/samsort_dw.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - real(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine samsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine samsort_dw

173
base/serial/aux/samsort_up.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine samsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine samsort_up

361
base/serial/aux/sasr.f90
Unescape Escape View File

@ -1,361 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine sasr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
real(psb_spk_) :: x(n)
! ..
! .. Local Scalars ..
real(psb_spk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='sasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call sisr_up(n,x)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='sasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call sisr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='sasr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine sisr_up(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine sisr_up
subroutine sisr_dw(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine sisr_dw
end subroutine sasr

410
base/serial/aux/sasrx.f90
Unescape Escape View File

@ -1,410 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine sasrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
real(psb_spk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call isasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call isasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call isasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call isasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call isasrx_up(n,x,indx)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call isasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call isasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call isasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call isasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call isasrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine isasrx_up(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine isasrx_up
subroutine isasrx_dw(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine isasrx_dw
end subroutine sasrx

173
base/serial/aux/smsort_dw.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - real(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine smsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine smsort_dw

173
base/serial/aux/smsort_up.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine smsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
real(psb_spk_) k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine smsort_up

80
base/serial/aux/smsr.f90
Unescape Escape View File

@ -1,80 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsr.f90
! Subroutine:
! Parameters:
subroutine smsr(n,x,idir)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n, idir
real(psb_spk_) :: x(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: lswap, iret, info, lp, k
real(psb_spk_) :: swap
if (n<0) then
return
endif
if (n<=1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='smsr')
call psb_error()
endif
select case(idir)
case (psb_sort_up_)
call smsort_up(n,x,iaux,iret)
case (psb_asort_up_)
call samsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call samsort_dw(n,x,iaux,iret)
case (psb_sort_down_)
call smsort_dw(n,x,iaux,iret)
end select
if (iret == 0) call psb_ip_reord(n,x,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='smsr')
call psb_error()
endif
return
end subroutine smsr

87
base/serial/aux/smsrx.f90
Unescape Escape View File

@ -1,87 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsrx.f90
! Subroutine:
! Parameters:
subroutine smsrx(n,x,indx,idir,flag)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n,idir,flag
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, lp, k,lswap, ixswap
real(psb_spk_) :: swap
if (n<0) then
return
endif
if (n == 0) return
if (flag == psb_sort_ovw_idx_) then
do k=1,n
indx(k) = k
enddo
end if
if (n == 1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='smsrx')
call psb_error()
endif
select case(idir)
case (psb_sort_up_)
call smsort_up(n,x,iaux,iret)
case (psb_asort_up_)
call samsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call samsort_dw(n,x,iaux,iret)
case (psb_sort_down_)
call smsort_dw(n,x,iaux,iret)
end select
if (iret == 0) call psb_ip_reord(n,x,indx,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='smsrx')
call psb_error()
endif
return
end subroutine smsrx

359
base/serial/aux/ssr.f90
Unescape Escape View File

@ -1,359 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine ssr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
real(psb_spk_) :: x(n)
! ..
! .. Local Scalars ..
real(psb_spk_) :: piv, xt, xk
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='ssr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call sisr_up(n,x)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='ssr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call sisr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call sisr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call sisr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='ssr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine sisr_up(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine sisr_up
subroutine sisr_dw(n,x)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: i,j
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine sisr_dw
end subroutine ssr

410
base/serial/aux/ssrx.f90
Unescape Escape View File

@ -1,410 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine ssrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
real(psb_spk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call issrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call issrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call issrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call issrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call issrx_up(n,x,indx)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call issrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call issrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call issrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call issrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call issrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine issrx_up(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine issrx_up
subroutine issrx_dw(n,x,indx)
implicit none
integer(psb_ipk_) :: n
real(psb_spk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
real(psb_spk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine issrx_dw
end subroutine ssrx

80
base/serial/aux/zacmp_mod.f90
Unescape Escape View File

@ -1,80 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module zacmp_mod
use psb_const_mod
interface operator(<)
module procedure zalt
end interface
interface operator(<=)
module procedure zale
end interface
interface operator(>)
module procedure zagt
end interface
interface operator(>=)
module procedure zage
end interface
contains
function zalt(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zalt
zalt = (abs(a) < abs(b))
end function zalt
function zale(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zale
zale = (abs(a) <= abs(b))
end function zale
function zagt(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zagt
zagt = (abs(a) > abs(b))
end function zagt
function zage(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zage
zage = (abs(a) >= abs(b))
end function zage
end module zacmp_mod

84
base/serial/aux/zalcmp_mod.f90
Unescape Escape View File

@ -1,84 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module zalcmp_mod
use psb_const_mod
interface operator(<)
module procedure zallt
end interface
interface operator(<=)
module procedure zalle
end interface
interface operator(>)
module procedure zalgt
end interface
interface operator(>=)
module procedure zalge
end interface
contains
function zallt(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zallt
zallt = (abs(real(a))<abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))<abs(aimag(b))))
end function zallt
function zalle(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zalle
zalle = (abs(real(a))<abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))<=abs(aimag(b))))
end function zalle
function zalgt(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zalgt
zalgt = (abs(real(a))>abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>abs(aimag(b))))
end function zalgt
function zalge(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zalge
zalge = (abs(real(a))>abs(real(b))).or. &
& ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b))))
end function zalge
end module zalcmp_mod

362
base/serial/aux/zalsr.f90
Unescape Escape View File

@ -1,362 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zalsr(n,x,dir)
use psb_serial_mod
use zalcmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
complex(psb_dpk_) :: x(n)
! ..
! .. Local Scalars ..
complex(psb_dpk_) :: xk, piv, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zalsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call izalsr_up(n,x)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zalsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call izalsr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='zalsr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine izalsr_up(n,x)
use zalcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izalsr_up
subroutine izalsr_dw(n,x)
use zalcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izalsr_dw
end subroutine zalsr

414
base/serial/aux/zalsrx.f90
Unescape Escape View File

@ -1,414 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zalsrx(n,x,indx,dir,flag)
use psb_serial_mod
use zalcmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
complex(psb_dpk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izalsrx_up(n,x,indx)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izalsrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine izalsrx_up(n,x,indx)
use zalcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izalsrx_up
subroutine izalsrx_dw(n,x,indx)
use zalcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izalsrx_dw
end subroutine zalsrx

173
base/serial/aux/zamsort_dw.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_dw.f90
!
! Subroutine: msort_dw
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - real(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_dw(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine zamsort_dw(n,k,l,iret)
use zacmp_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine zamsort_dw

173
base/serial/aux/zamsort_up.f90
Unescape Escape View File

@ -1,173 +0,0 @@
!
! Parallel Sparse BLAS version 3.4
! (C) Copyright 2006, 2010, 2015
! Salvatore Filippone University of Rome Tor Vergata
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
! File: msort_up.f90
!
! Subroutine: msort_up
! This subroutine sorts an integer array into ascending order.
!
! Arguments:
! n - integer Input: size of the array
! k - integer(*) input: array of keys to be sorted
! l - integer(0:n+1) output: link list
! iret - integer output: 0 Normal termination
! 1 the array was already sorted
! *
! REFERENCES = (1) D. E. Knuth *
! The Art of Computer Programming, *
! vol.3: Sorting and Searching *
! Addison-Wesley, 1973 *
! *
! call msort_up(n,x,iaux,iret)
!
! if (iret == 0) then
! lp = iaux(0)
! k = 1
! do
! if ((lp == 0).or.(k>n)) exit
! do
! if (lp >= k) exit
! lp = iaux(lp)
! end do
! iswap = x(lp)
! x(lp) = x(k)
! x(k) = iswap
! lswap = iaux(lp)
! iaux(lp) = iaux(k)
! iaux(k) = lp
! lp = lswap
! k = k + 1
! enddo
! end if
!
!
subroutine zamsort_up(n,k,l,iret)
use zacmp_mod
implicit none
integer(psb_ipk_) :: n, iret
complex(psb_dpk_) k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine zamsort_up

76
base/serial/aux/zamsr.f90
Unescape Escape View File

@ -1,76 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsr.f90
! Subroutine:
! Parameters:
subroutine zamsr(n,x,idir)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n, idir
complex(psb_dpk_) :: x(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: lswap, iret, info, lp, k
complex(psb_dpk_) :: swap
if (n<0) then
!!$ write(psb_err_unit,*) 'Error: IMSR: N<0'
return
endif
if (n<=1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsr')
call psb_error()
endif
if (idir == psb_asort_up_) then
call zamsort_up(n,x,iaux,iret)
else
call zamsort_dw(n,x,iaux,iret)
end if
if (iret == 0) call psb_ip_reord(n,x,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsr')
call psb_error()
endif
return
end subroutine zamsr

82
base/serial/aux/zamsrx.f90
Unescape Escape View File

@ -1,82 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: imsrx.f90
! Subroutine:
! Parameters:
subroutine zamsrx(n,x,indx,idir,flag)
use psb_serial_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_) :: n,idir,flag
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, lp, k,lswap, ixswap
complex(psb_dpk_) :: swap
if (n<0) then
return
endif
if (n == 0) return
if (flag == psb_sort_ovw_idx_) then
do k=1,n
indx(k) = k
enddo
end if
if (n == 1) return
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsrx')
call psb_error()
endif
if (idir == psb_asort_up_) then
call zamsort_up(n,x,iaux,iret)
else
call zamsort_dw(n,x,iaux,iret)
end if
if (iret == 0) call psb_ip_reord(n,x,indx,iaux)
deallocate(iaux,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsrx')
call psb_error()
endif
return
end subroutine zamsrx

362
base/serial/aux/zasr.f90
Unescape Escape View File

@ -1,362 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zasr(n,x,dir)
use psb_serial_mod
use zacmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
complex(psb_dpk_) :: x(n)
! ..
! .. Local Scalars ..
complex(psb_dpk_) :: xk, piv, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call izasr_up(n,x)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zasr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call izasr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='zasr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine izasr_up(n,x)
use zacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izasr_up
subroutine izasr_dw(n,x)
use zacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izasr_dw
end subroutine zasr

414
base/serial/aux/zasrx.f90
Unescape Escape View File

@ -1,414 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zasrx(n,x,indx,dir,flag)
use psb_serial_mod
use zacmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
complex(psb_dpk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izasrx_up(n,x,indx)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izasrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine izasrx_up(n,x,indx)
use zacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izasrx_up
subroutine izasrx_dw(n,x,indx)
use zacmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izasrx_dw
end subroutine zasrx

80
base/serial/aux/zlcmp_mod.f90
Unescape Escape View File

@ -1,80 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module zlcmp_mod
use psb_const_mod
interface operator(<)
module procedure zllt
end interface
interface operator(<=)
module procedure zlle
end interface
interface operator(>)
module procedure zlgt
end interface
interface operator(>=)
module procedure zlge
end interface
contains
function zllt(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zllt
zllt = (real(a)<real(b)).or.((real(a) == real(b)).and.(aimag(a)<aimag(b)))
end function zllt
function zlle(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zlle
zlle = (real(a)<real(b)).or.((real(a) == real(b)).and.(aimag(a)<=aimag(b)))
end function zlle
function zlgt(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zlgt
zlgt = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>aimag(b)))
end function zlgt
function zlge(a,b)
use psb_const_mod
complex(psb_dpk_), intent(in) :: a,b
logical :: zlge
zlge = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>=aimag(b)))
end function zlge
end module zlcmp_mod

362
base/serial/aux/zlsr.f90
Unescape Escape View File

@ -1,362 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zlsr(n,x,dir)
use psb_serial_mod
use zlcmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir
complex(psb_dpk_) :: x(n)
! ..
! .. Local Scalars ..
complex(psb_dpk_) :: xk, piv, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_lsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zlsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call izlsr_up(n,x)
endif
case(psb_lsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zlsr',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call izlsr_dw(n,x)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='zlsr',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine izlsr_up(n,x)
use zlcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izlsr_up
subroutine izlsr_dw(n,x)
use zlcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: i,j
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izlsr_dw
end subroutine zlsr

414
base/serial/aux/zlsrx.f90
Unescape Escape View File

@ -1,414 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zlsrx(n,x,indx,dir,flag)
use psb_serial_mod
use zlcmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer(psb_ipk_), intent(in) :: n, dir, flag
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
! ..
! .. Local Scalars ..
complex(psb_dpk_) :: piv, xk, xt
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
integer(psb_ipk_) :: ixt, n1, n2
integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=16
integer(psb_ipk_) :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='wrong flag')
call psb_error()
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_lsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izlsrx_up(n,x,indx)
endif
case(psb_lsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = indx(j)
x(j) = x(lpiv)
indx(j) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = indx(i)
x(i) = x(lpiv)
indx(i) = indx(lpiv)
x(lpiv) = xt
indx(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='impossible pivot condition')
call psb_error()
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izlsrx_dw(n,x,indx)
endif
case default
call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='wrong dir')
call psb_error()
end select
return
contains
subroutine izlsrx_up(n,x,indx)
use zlcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izlsrx_up
subroutine izlsrx_dw(n,x,indx)
use zlcmp_mod
implicit none
integer(psb_ipk_) :: n
complex(psb_dpk_) :: x(n)
integer(psb_ipk_) :: indx(n)
integer(psb_ipk_) :: i,j,ix
complex(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izlsrx_dw
end subroutine zlsrx
Write Preview
Loading…
Cancel
Save