From ff86462e75b39689f53b252ac265e6051e5d3091 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 6 May 2015 09:40:25 +0000 Subject: [PATCH] psblas3: 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. --- base/serial/aux/Makefile | 52 ----- base/serial/aux/cacmp_mod.f90 | 80 ------- base/serial/aux/calcmp_mod.f90 | 84 ------- base/serial/aux/calsr.f90 | 362 ---------------------------- base/serial/aux/calsrx.f90 | 414 --------------------------------- base/serial/aux/camsort_dw.f90 | 173 -------------- base/serial/aux/camsort_up.f90 | 173 -------------- base/serial/aux/camsr.f90 | 75 ------ base/serial/aux/camsrx.f90 | 82 ------- base/serial/aux/casr.f90 | 362 ---------------------------- base/serial/aux/casrx.f90 | 414 --------------------------------- base/serial/aux/clcmp_mod.f90 | 80 ------- base/serial/aux/clsr.f90 | 362 ---------------------------- base/serial/aux/clsrx.f90 | 414 --------------------------------- base/serial/aux/damsort_dw.f90 | 173 -------------- base/serial/aux/damsort_up.f90 | 173 -------------- base/serial/aux/dasr.f90 | 361 ---------------------------- base/serial/aux/dasrx.f90 | 409 -------------------------------- base/serial/aux/dmsort_dw.f90 | 173 -------------- base/serial/aux/dmsort_up.f90 | 173 -------------- base/serial/aux/dmsr.f90 | 81 ------- base/serial/aux/dmsrx.f90 | 88 ------- base/serial/aux/dsr.f90 | 359 ---------------------------- base/serial/aux/dsrx.f90 | 410 -------------------------------- base/serial/aux/iamsort_dw.f90 | 173 -------------- base/serial/aux/iamsort_up.f90 | 173 -------------- base/serial/aux/iasr.f90 | 361 ---------------------------- base/serial/aux/iasrx.f90 | 410 -------------------------------- base/serial/aux/ibsrch.f | 58 ----- base/serial/aux/idot.f90 | 58 ----- base/serial/aux/imsr.f90 | 80 ------- base/serial/aux/imsru.f90 | 64 ----- base/serial/aux/imsrx.f90 | 88 ------- base/serial/aux/inrm2.f90 | 58 ----- base/serial/aux/isaperm.f | 104 --------- base/serial/aux/isr.f90 | 360 ---------------------------- base/serial/aux/isrx.f90 | 410 -------------------------------- base/serial/aux/issrch.f | 51 ---- base/serial/aux/msort_dw.f90 | 172 -------------- base/serial/aux/msort_up.f90 | 172 -------------- base/serial/aux/samsort_dw.f90 | 173 -------------- base/serial/aux/samsort_up.f90 | 173 -------------- base/serial/aux/sasr.f90 | 361 ---------------------------- base/serial/aux/sasrx.f90 | 410 -------------------------------- base/serial/aux/smsort_dw.f90 | 173 -------------- base/serial/aux/smsort_up.f90 | 173 -------------- base/serial/aux/smsr.f90 | 80 ------- base/serial/aux/smsrx.f90 | 87 ------- base/serial/aux/ssr.f90 | 359 ---------------------------- base/serial/aux/ssrx.f90 | 410 -------------------------------- base/serial/aux/zacmp_mod.f90 | 80 ------- base/serial/aux/zalcmp_mod.f90 | 84 ------- base/serial/aux/zalsr.f90 | 362 ---------------------------- base/serial/aux/zalsrx.f90 | 414 --------------------------------- base/serial/aux/zamsort_dw.f90 | 173 -------------- base/serial/aux/zamsort_up.f90 | 173 -------------- base/serial/aux/zamsr.f90 | 76 ------ base/serial/aux/zamsrx.f90 | 82 ------- base/serial/aux/zasr.f90 | 362 ---------------------------- base/serial/aux/zasrx.f90 | 414 --------------------------------- base/serial/aux/zlcmp_mod.f90 | 80 ------- base/serial/aux/zlsr.f90 | 362 ---------------------------- base/serial/aux/zlsrx.f90 | 414 --------------------------------- 63 files changed, 13794 deletions(-) delete mode 100644 base/serial/aux/Makefile delete mode 100644 base/serial/aux/cacmp_mod.f90 delete mode 100644 base/serial/aux/calcmp_mod.f90 delete mode 100644 base/serial/aux/calsr.f90 delete mode 100644 base/serial/aux/calsrx.f90 delete mode 100644 base/serial/aux/camsort_dw.f90 delete mode 100644 base/serial/aux/camsort_up.f90 delete mode 100644 base/serial/aux/camsr.f90 delete mode 100644 base/serial/aux/camsrx.f90 delete mode 100644 base/serial/aux/casr.f90 delete mode 100644 base/serial/aux/casrx.f90 delete mode 100644 base/serial/aux/clcmp_mod.f90 delete mode 100644 base/serial/aux/clsr.f90 delete mode 100644 base/serial/aux/clsrx.f90 delete mode 100644 base/serial/aux/damsort_dw.f90 delete mode 100644 base/serial/aux/damsort_up.f90 delete mode 100644 base/serial/aux/dasr.f90 delete mode 100644 base/serial/aux/dasrx.f90 delete mode 100644 base/serial/aux/dmsort_dw.f90 delete mode 100644 base/serial/aux/dmsort_up.f90 delete mode 100644 base/serial/aux/dmsr.f90 delete mode 100644 base/serial/aux/dmsrx.f90 delete mode 100644 base/serial/aux/dsr.f90 delete mode 100644 base/serial/aux/dsrx.f90 delete mode 100644 base/serial/aux/iamsort_dw.f90 delete mode 100644 base/serial/aux/iamsort_up.f90 delete mode 100644 base/serial/aux/iasr.f90 delete mode 100644 base/serial/aux/iasrx.f90 delete mode 100644 base/serial/aux/ibsrch.f delete mode 100644 base/serial/aux/idot.f90 delete mode 100644 base/serial/aux/imsr.f90 delete mode 100644 base/serial/aux/imsru.f90 delete mode 100644 base/serial/aux/imsrx.f90 delete mode 100644 base/serial/aux/inrm2.f90 delete mode 100644 base/serial/aux/isaperm.f delete mode 100644 base/serial/aux/isr.f90 delete mode 100644 base/serial/aux/isrx.f90 delete mode 100644 base/serial/aux/issrch.f delete mode 100644 base/serial/aux/msort_dw.f90 delete mode 100644 base/serial/aux/msort_up.f90 delete mode 100644 base/serial/aux/samsort_dw.f90 delete mode 100644 base/serial/aux/samsort_up.f90 delete mode 100644 base/serial/aux/sasr.f90 delete mode 100644 base/serial/aux/sasrx.f90 delete mode 100644 base/serial/aux/smsort_dw.f90 delete mode 100644 base/serial/aux/smsort_up.f90 delete mode 100644 base/serial/aux/smsr.f90 delete mode 100644 base/serial/aux/smsrx.f90 delete mode 100644 base/serial/aux/ssr.f90 delete mode 100644 base/serial/aux/ssrx.f90 delete mode 100644 base/serial/aux/zacmp_mod.f90 delete mode 100644 base/serial/aux/zalcmp_mod.f90 delete mode 100644 base/serial/aux/zalsr.f90 delete mode 100644 base/serial/aux/zalsrx.f90 delete mode 100644 base/serial/aux/zamsort_dw.f90 delete mode 100644 base/serial/aux/zamsort_up.f90 delete mode 100644 base/serial/aux/zamsr.f90 delete mode 100644 base/serial/aux/zamsrx.f90 delete mode 100644 base/serial/aux/zasr.f90 delete mode 100644 base/serial/aux/zasrx.f90 delete mode 100644 base/serial/aux/zlcmp_mod.f90 delete mode 100644 base/serial/aux/zlsr.f90 delete mode 100644 base/serial/aux/zlsrx.f90 diff --git a/base/serial/aux/Makefile b/base/serial/aux/Makefile deleted file mode 100644 index 19ed221ea..000000000 --- a/base/serial/aux/Makefile +++ /dev/null @@ -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 - diff --git a/base/serial/aux/cacmp_mod.f90 b/base/serial/aux/cacmp_mod.f90 deleted file mode 100644 index 2f170d672..000000000 --- a/base/serial/aux/cacmp_mod.f90 +++ /dev/null @@ -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 - diff --git a/base/serial/aux/calcmp_mod.f90 b/base/serial/aux/calcmp_mod.f90 deleted file mode 100644 index 61633c539..000000000 --- a/base/serial/aux/calcmp_mod.f90 +++ /dev/null @@ -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 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 - diff --git a/base/serial/aux/calsr.f90 b/base/serial/aux/calsr.f90 deleted file mode 100644 index 0493ef5d6..000000000 --- a/base/serial/aux/calsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/calsrx.f90 b/base/serial/aux/calsrx.f90 deleted file mode 100644 index dc82ccf31..000000000 --- a/base/serial/aux/calsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/camsort_dw.f90 b/base/serial/aux/camsort_dw.f90 deleted file mode 100644 index 7763d3614..000000000 --- a/base/serial/aux/camsort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/camsort_up.f90 b/base/serial/aux/camsort_up.f90 deleted file mode 100644 index ce9ac22ea..000000000 --- a/base/serial/aux/camsort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/camsr.f90 b/base/serial/aux/camsr.f90 deleted file mode 100644 index 9f3057bc7..000000000 --- a/base/serial/aux/camsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/camsrx.f90 b/base/serial/aux/camsrx.f90 deleted file mode 100644 index 12289a9d6..000000000 --- a/base/serial/aux/camsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/casr.f90 b/base/serial/aux/casr.f90 deleted file mode 100644 index 12cb3febe..000000000 --- a/base/serial/aux/casr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/casrx.f90 b/base/serial/aux/casrx.f90 deleted file mode 100644 index 6686bcea0..000000000 --- a/base/serial/aux/casrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/clcmp_mod.f90 b/base/serial/aux/clcmp_mod.f90 deleted file mode 100644 index a77d2aba0..000000000 --- a/base/serial/aux/clcmp_mod.f90 +++ /dev/null @@ -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 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 - diff --git a/base/serial/aux/clsr.f90 b/base/serial/aux/clsr.f90 deleted file mode 100644 index 469dd46ea..000000000 --- a/base/serial/aux/clsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/clsrx.f90 b/base/serial/aux/clsrx.f90 deleted file mode 100644 index 26165ad9f..000000000 --- a/base/serial/aux/clsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/damsort_dw.f90 b/base/serial/aux/damsort_dw.f90 deleted file mode 100644 index fc3ef5b75..000000000 --- a/base/serial/aux/damsort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/damsort_up.f90 b/base/serial/aux/damsort_up.f90 deleted file mode 100644 index ca4e7fd8a..000000000 --- a/base/serial/aux/damsort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dasr.f90 b/base/serial/aux/dasr.f90 deleted file mode 100644 index 10d14fe45..000000000 --- a/base/serial/aux/dasr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dasrx.f90 b/base/serial/aux/dasrx.f90 deleted file mode 100644 index 9e52ce53a..000000000 --- a/base/serial/aux/dasrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dmsort_dw.f90 b/base/serial/aux/dmsort_dw.f90 deleted file mode 100644 index 91c76d0a3..000000000 --- a/base/serial/aux/dmsort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dmsort_up.f90 b/base/serial/aux/dmsort_up.f90 deleted file mode 100644 index 01cf5606d..000000000 --- a/base/serial/aux/dmsort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dmsr.f90 b/base/serial/aux/dmsr.f90 deleted file mode 100644 index 4248f52ed..000000000 --- a/base/serial/aux/dmsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dmsrx.f90 b/base/serial/aux/dmsrx.f90 deleted file mode 100644 index f8027f1c4..000000000 --- a/base/serial/aux/dmsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dsr.f90 b/base/serial/aux/dsr.f90 deleted file mode 100644 index 864718271..000000000 --- a/base/serial/aux/dsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/dsrx.f90 b/base/serial/aux/dsrx.f90 deleted file mode 100644 index 8352f29b1..000000000 --- a/base/serial/aux/dsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/iamsort_dw.f90 b/base/serial/aux/iamsort_dw.f90 deleted file mode 100644 index 08d3747e8..000000000 --- a/base/serial/aux/iamsort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/iamsort_up.f90 b/base/serial/aux/iamsort_up.f90 deleted file mode 100644 index 4e6462f59..000000000 --- a/base/serial/aux/iamsort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/iasr.f90 b/base/serial/aux/iasr.f90 deleted file mode 100644 index 7d5b49d86..000000000 --- a/base/serial/aux/iasr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/iasrx.f90 b/base/serial/aux/iasrx.f90 deleted file mode 100644 index 60e8d5c39..000000000 --- a/base/serial/aux/iasrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/ibsrch.f b/base/serial/aux/ibsrch.f deleted file mode 100644 index 8f2454b7f..000000000 --- a/base/serial/aux/ibsrch.f +++ /dev/null @@ -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 - diff --git a/base/serial/aux/idot.f90 b/base/serial/aux/idot.f90 deleted file mode 100644 index dfb75f701..000000000 --- a/base/serial/aux/idot.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/imsr.f90 b/base/serial/aux/imsr.f90 deleted file mode 100644 index 299b56879..000000000 --- a/base/serial/aux/imsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/imsru.f90 b/base/serial/aux/imsru.f90 deleted file mode 100644 index c6efa64b6..000000000 --- a/base/serial/aux/imsru.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/imsrx.f90 b/base/serial/aux/imsrx.f90 deleted file mode 100644 index 37cff99fc..000000000 --- a/base/serial/aux/imsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/inrm2.f90 b/base/serial/aux/inrm2.f90 deleted file mode 100644 index 4f1392a4c..000000000 --- a/base/serial/aux/inrm2.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/isaperm.f b/base/serial/aux/isaperm.f deleted file mode 100644 index 2e8488336..000000000 --- a/base/serial/aux/isaperm.f +++ /dev/null @@ -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 diff --git a/base/serial/aux/isr.f90 b/base/serial/aux/isr.f90 deleted file mode 100644 index 3c60d1759..000000000 --- a/base/serial/aux/isr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/isrx.f90 b/base/serial/aux/isrx.f90 deleted file mode 100644 index a9f4a340b..000000000 --- a/base/serial/aux/isrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/issrch.f b/base/serial/aux/issrch.f deleted file mode 100644 index 7353239a2..000000000 --- a/base/serial/aux/issrch.f +++ /dev/null @@ -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 - diff --git a/base/serial/aux/msort_dw.f90 b/base/serial/aux/msort_dw.f90 deleted file mode 100644 index 99a46abd5..000000000 --- a/base/serial/aux/msort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/msort_up.f90 b/base/serial/aux/msort_up.f90 deleted file mode 100644 index 69400266c..000000000 --- a/base/serial/aux/msort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/samsort_dw.f90 b/base/serial/aux/samsort_dw.f90 deleted file mode 100644 index d78209a21..000000000 --- a/base/serial/aux/samsort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/samsort_up.f90 b/base/serial/aux/samsort_up.f90 deleted file mode 100644 index 636676fb1..000000000 --- a/base/serial/aux/samsort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/sasr.f90 b/base/serial/aux/sasr.f90 deleted file mode 100644 index 6ea252d71..000000000 --- a/base/serial/aux/sasr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/sasrx.f90 b/base/serial/aux/sasrx.f90 deleted file mode 100644 index 9d7c25f83..000000000 --- a/base/serial/aux/sasrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/smsort_dw.f90 b/base/serial/aux/smsort_dw.f90 deleted file mode 100644 index e41b8dbbf..000000000 --- a/base/serial/aux/smsort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/smsort_up.f90 b/base/serial/aux/smsort_up.f90 deleted file mode 100644 index 04805bbe3..000000000 --- a/base/serial/aux/smsort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/smsr.f90 b/base/serial/aux/smsr.f90 deleted file mode 100644 index 31f4e13e5..000000000 --- a/base/serial/aux/smsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/smsrx.f90 b/base/serial/aux/smsrx.f90 deleted file mode 100644 index a57d5724b..000000000 --- a/base/serial/aux/smsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/ssr.f90 b/base/serial/aux/ssr.f90 deleted file mode 100644 index 60d4eaaca..000000000 --- a/base/serial/aux/ssr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/ssrx.f90 b/base/serial/aux/ssrx.f90 deleted file mode 100644 index 8f5e93669..000000000 --- a/base/serial/aux/ssrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zacmp_mod.f90 b/base/serial/aux/zacmp_mod.f90 deleted file mode 100644 index 18e961796..000000000 --- a/base/serial/aux/zacmp_mod.f90 +++ /dev/null @@ -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 - diff --git a/base/serial/aux/zalcmp_mod.f90 b/base/serial/aux/zalcmp_mod.f90 deleted file mode 100644 index d1971ee59..000000000 --- a/base/serial/aux/zalcmp_mod.f90 +++ /dev/null @@ -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 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 - diff --git a/base/serial/aux/zalsr.f90 b/base/serial/aux/zalsr.f90 deleted file mode 100644 index 35950db0b..000000000 --- a/base/serial/aux/zalsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zalsrx.f90 b/base/serial/aux/zalsrx.f90 deleted file mode 100644 index 8b8e4b7f6..000000000 --- a/base/serial/aux/zalsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zamsort_dw.f90 b/base/serial/aux/zamsort_dw.f90 deleted file mode 100644 index 2f92537e6..000000000 --- a/base/serial/aux/zamsort_dw.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zamsort_up.f90 b/base/serial/aux/zamsort_up.f90 deleted file mode 100644 index 46814d8fd..000000000 --- a/base/serial/aux/zamsort_up.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zamsr.f90 b/base/serial/aux/zamsr.f90 deleted file mode 100644 index 45c799670..000000000 --- a/base/serial/aux/zamsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zamsrx.f90 b/base/serial/aux/zamsrx.f90 deleted file mode 100644 index ea4f6673e..000000000 --- a/base/serial/aux/zamsrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zasr.f90 b/base/serial/aux/zasr.f90 deleted file mode 100644 index 256fc3b12..000000000 --- a/base/serial/aux/zasr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zasrx.f90 b/base/serial/aux/zasrx.f90 deleted file mode 100644 index 8a8003c72..000000000 --- a/base/serial/aux/zasrx.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zlcmp_mod.f90 b/base/serial/aux/zlcmp_mod.f90 deleted file mode 100644 index 0b31d142c..000000000 --- a/base/serial/aux/zlcmp_mod.f90 +++ /dev/null @@ -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 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 - diff --git a/base/serial/aux/zlsr.f90 b/base/serial/aux/zlsr.f90 deleted file mode 100644 index dfd2fb3a3..000000000 --- a/base/serial/aux/zlsr.f90 +++ /dev/null @@ -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 diff --git a/base/serial/aux/zlsrx.f90 b/base/serial/aux/zlsrx.f90 deleted file mode 100644 index f1b48b684..000000000 --- a/base/serial/aux/zlsrx.f90 +++ /dev/null @@ -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