You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
199 lines
5.6 KiB
Fortran
199 lines
5.6 KiB
Fortran
C
|
|
C Parallel Sparse BLAS v2.0
|
|
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
|
|
C Alfredo Buttari University of Rome Tor Vergata
|
|
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 ISRX(N,X,INDX)
|
|
C
|
|
C Quicksort with indices into original positions.
|
|
C Adapted from a number of sources, including Don Knuth's TAOCP.
|
|
C
|
|
C .. Scalar Arguments ..
|
|
INTEGER N
|
|
C ..
|
|
C .. Array Arguments ..
|
|
INTEGER INDX(N),X(N)
|
|
C ..
|
|
C .. Local Scalars ..
|
|
INTEGER I, J, II, XX, ILX, IUX, ISTP, PIV, LPIV
|
|
INTEGER IT1, IT2, N1, N2
|
|
INTEGER MAXSTACK,NPARMS,ITHRS
|
|
PARAMETER (MAXSTACK=64,NPARMS=3,ITHRS=16)
|
|
INTEGER ISTACK(NPARMS,MAXSTACK)
|
|
C ..
|
|
|
|
DO I=1, N
|
|
INDX(I) = I
|
|
ENDDO
|
|
C
|
|
C Small inputs will only get through insertion sort.
|
|
C
|
|
IF (N.GT.ITHRS) THEN
|
|
C
|
|
C Init stack pointer
|
|
C
|
|
ISTP = 1
|
|
ISTACK(1,ISTP) = 1
|
|
ISTACK(2,ISTP) = N
|
|
|
|
DO WHILE (ISTP.GT.0)
|
|
ILX = ISTACK(1,ISTP)
|
|
IUX = ISTACK(2,ISTP)
|
|
ISTP = ISTP - 1
|
|
C
|
|
C Choose a pivot with median-of-three heuristics, leave it
|
|
C in the LPIV location
|
|
C
|
|
I = ILX
|
|
J = IUX
|
|
LPIV = (I+J)/2
|
|
PIV = X(LPIV)
|
|
IF (PIV.LT.X(I)) THEN
|
|
IT1 = X(I)
|
|
IT2 = INDX(I)
|
|
X(I) = X(LPIV)
|
|
INDX(I) = INDX(LPIV)
|
|
X(LPIV) = IT1
|
|
INDX(LPIV) = IT2
|
|
PIV = X(LPIV)
|
|
ENDIF
|
|
IF (PIV.GT.X(J)) THEN
|
|
IT1 = X(J)
|
|
IT2 = INDX(J)
|
|
X(J) = X(LPIV)
|
|
INDX(J) = INDX(LPIV)
|
|
X(LPIV) = IT1
|
|
INDX(LPIV) = IT2
|
|
PIV = X(LPIV)
|
|
ENDIF
|
|
IF (PIV.LT.X(I)) THEN
|
|
IT1 = X(I)
|
|
IT2 = INDX(I)
|
|
X(I) = X(LPIV)
|
|
INDX(I) = INDX(LPIV)
|
|
X(LPIV) = IT1
|
|
INDX(LPIV) = IT2
|
|
PIV = X(LPIV)
|
|
ENDIF
|
|
C
|
|
C Now PIV is correct; place it into first location
|
|
C
|
|
IT1 = X(I)
|
|
IT2 = INDX(I)
|
|
X(I) = X(LPIV)
|
|
INDX(I) = INDX(LPIV)
|
|
X(LPIV) = IT1
|
|
INDX(LPIV) = IT2
|
|
|
|
I = ILX - 1
|
|
J = IUX + 1
|
|
|
|
130 CONTINUE
|
|
I = I + 1
|
|
XK = X(I)
|
|
IF (XK.LT.PIV) GOTO 130
|
|
C
|
|
C Ensure finite termination for next loop
|
|
C
|
|
IT1 = XK
|
|
X(I) = PIV
|
|
140 CONTINUE
|
|
J = J - 1
|
|
XK = X(J)
|
|
IF (XK.GT.PIV) GOTO 140
|
|
X(I) = IT1
|
|
150 CONTINUE
|
|
|
|
IF (J.GT.I) THEN
|
|
IT1 = X(I)
|
|
IT2 = INDX(I)
|
|
X(I) = X(J)
|
|
INDX(I) = INDX(J)
|
|
X(J) = IT1
|
|
INDX(J) = IT2
|
|
GO TO 130
|
|
END IF
|
|
|
|
if (i.eq.ilx) then
|
|
if (x(i).ne.piv) then
|
|
write(0,*)
|
|
+ 'ISRX:: Should never ever get here????!!!!'
|
|
stop
|
|
endif
|
|
i = i + 1
|
|
endif
|
|
|
|
N1 = (I-1)-ILX+1
|
|
N2 = IUX-(I)+1
|
|
IF (N1.GT.N2) THEN
|
|
if (n1.gt.ithrs) then
|
|
ISTP = ISTP + 1
|
|
ISTACK(1,ISTP) = ILX
|
|
ISTACK(2,ISTP) = I-1
|
|
endif
|
|
if (n2.gt.ithrs) then
|
|
ISTP = ISTP + 1
|
|
ISTACK(1,ISTP) = I
|
|
ISTACK(2,ISTP) = IUX
|
|
endif
|
|
ELSE
|
|
if (n2.gt.ithrs) then
|
|
ISTP = ISTP + 1
|
|
ISTACK(1,ISTP) = I
|
|
ISTACK(2,ISTP) = IUX
|
|
endif
|
|
if (n1.gt.ithrs) then
|
|
ISTP = ISTP + 1
|
|
ISTACK(1,ISTP) = ILX
|
|
ISTACK(2,ISTP) = I-1
|
|
endif
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
|
|
DO J=N-1,1,-1
|
|
IF (X(J+1).LT.X(J)) THEN
|
|
XX = X(J)
|
|
II = INDX(J)
|
|
I=J+1
|
|
100 CONTINUE
|
|
X(I-1) = X(I)
|
|
INDX(I-1) = INDX(I)
|
|
I = I+1
|
|
IF ((I.LE.N)) then
|
|
if (X(I).LT.XX) GOTO 100
|
|
endif
|
|
X(I-1) = XX
|
|
INDX(I-1) = II
|
|
ENDIF
|
|
ENDDO
|
|
|
|
RETURN
|
|
|
|
END
|