Paste from dlasrt2 at 2022-02-22 15:49:56I want to paste
!// ForQuill v1.01 Beta www.fcode.cn
!
!
Subroutine dlasrt2(id, n, d, key, info)
!
! -- ScaLAPACK routine (version 1.7) --
! University of Tennessee, Knoxville, Oak Ridge National Laboratory,
! and University of California, Berkeley.
! May 1, 1997
!
! .. Scalar Arguments ..
Character id
Integer info, n
! ..
! .. Array Arguments ..
Integer key(*)
Double Precision d(*)
! ..
!
! Purpose
! =======
!
! Sort the numbers in D in increasing order (if ID = 'I') or
! in decreasing order (if ID = 'D' ).
!
! Use Quick Sort, reverting to Insertion sort on arrays of
! size <= 20. Dimension of STACK limits N to about 2**32.
!
! Arguments
! =========
!
! ID (input) CHARACTER*1
! = 'I': sort D in increasing order;
! = 'D': sort D in decreasing order.
!
! N (input) INTEGER
! The length of the array D.
!
! D (input/output) DOUBLE PRECISION array, dimension (N)
! On entry, the array to be sorted.
! On exit, D has been sorted into increasing order
! (D(1) <= ... <= D(N) ) or into decreasing order
! (D(1) >= ... >= D(N) ), depending on ID.
!
! KEY (input/output) INTEGER array, dimension (N)
! On entry, KEY contains a key to each of the entries in D()
! Typically, KEY(I) = I for all I
! On exit, KEY is permuted in exactly the same manner as
! D() was permuted from input to output
! Therefore, if KEY(I) = I for all I upon input, then
! D_out(I) = D_in(KEY(I))
!
! INFO (output) INTEGER
! = 0: successful exit
! < 0: if INFO = -i, the i-th argument had an illegal value
!
! =====================================================================
!
! .. Parameters ..
Integer select
Parameter (select=20)
! ..
! .. Local Scalars ..
Integer dir, endd, i, j, start, stkpnt, tmpkey
Double Precision d1, d2, d3, dmnmx, tmp
! ..
! .. Local Arrays ..
Integer stack(2, 32)
! ..
! .. External Functions ..
Logical lsame
External lsame
! ..
! .. External Subroutines ..
External xerbla
! ..
! .. Executable Statements ..
!
! Test the input paramters.
!
!
info = 0
dir = -1
If (lsame(id,'D')) Then
dir = 0
Else If (lsame(id,'I')) Then
dir = 1
End If
If (dir==-1) Then
info = -1
Else If (n<0) Then
info = -2
End If
If (info/=0) Then
Call xerbla('DLASRT2', -info)
Return
End If
!
! Quick return if possible
!
If (n<=1) Return
!
stkpnt = 1
stack(1, 1) = 1
stack(2, 1) = n
10 Continue
start = stack(1, stkpnt)
endd = stack(2, stkpnt)
stkpnt = stkpnt - 1
If (endd-start>0) Then
!
! Do Insertion sort on D( START:ENDD )
!
If (dir==0) Then
!
! Sort into decreasing order
!
Do i = start + 1, endd
Do j = i, start + 1, -1
If (d(j)>d(j-1)) Then
dmnmx = d(j)
d(j) = d(j-1)
d(j-1) = dmnmx
tmpkey = key(j)
key(j) = key(j-1)
key(j-1) = tmpkey
Else
Goto 30
End If
End Do
30 End Do
!
Else
!
! Sort into increasing order
!
Do i = start + 1, endd
Do j = i, start + 1, -1
If (d(j)<d(j-1)) Then
dmnmx = d(j)
d(j) = d(j-1)
d(j-1) = dmnmx
tmpkey = key(j)
key(j) = key(j-1)
key(j-1) = tmpkey
Else
Goto 50
End If
End Do
50 End Do
!
End If
!
Else If (endd-start>select) Then
!
! Partition D( START:ENDD ) and stack parts, largest one first
!
! Choose partition entry as median of 3
!
d1 = d(start)
d2 = d(endd)
i = (start+endd)/2
d3 = d(i)
If (d1<d2) Then
If (d3<d1) Then
dmnmx = d1
Else If (d3<d2) Then
dmnmx = d3
Else
dmnmx = d2
End If
Else
If (d3<d2) Then
dmnmx = d2
Else If (d3<d1) Then
dmnmx = d3
Else
dmnmx = d1
End If
End If
!
If (dir==0) Then
!
! Sort into decreasing order
!
i = start - 1
j = endd + 1
60 Continue
70 Continue
j = j - 1
If (d(j)<dmnmx) Goto 70
80 Continue
i = i + 1
If (d(i)>dmnmx) Goto 80
If (i<j) Then
tmp = d(i)
d(i) = d(j)
d(j) = tmp
tmpkey = key(j)
key(j) = key(i)
key(i) = tmpkey
Goto 60
End If
If (j-start>endd-j-1) Then
stkpnt = stkpnt + 1
stack(1, stkpnt) = start
stack(2, stkpnt) = j
stkpnt = stkpnt + 1
stack(1, stkpnt) = j + 1
stack(2, stkpnt) = endd
Else
stkpnt = stkpnt + 1
stack(1, stkpnt) = j + 1
stack(2, stkpnt) = endd
stkpnt = stkpnt + 1
stack(1, stkpnt) = start
stack(2, stkpnt) = j
End If
Else
!
! Sort into increasing order
!
i = start - 1
j = endd + 1
90 Continue
100 Continue
j = j - 1
If (d(j)>dmnmx) Goto 100
110 Continue
i = i + 1
If (d(i)<dmnmx) Goto 110
If (i<j) Then
tmp = d(i)
d(i) = d(j)
d(j) = tmp
tmpkey = key(j)
key(j) = key(i)
key(i) = tmpkey
Goto 90
End If
If (j-start>endd-j-1) Then
stkpnt = stkpnt + 1
stack(1, stkpnt) = start
stack(2, stkpnt) = j
stkpnt = stkpnt + 1
stack(1, stkpnt) = j + 1
stack(2, stkpnt) = endd
Else
stkpnt = stkpnt + 1
stack(1, stkpnt) = j + 1
stack(2, stkpnt) = endd
stkpnt = stkpnt + 1
stack(1, stkpnt) = start
stack(2, stkpnt) = j
End If
End If
End If
If (stkpnt>0) Goto 10
!
!
Return
!
! End of DLASRT2
!
End Subroutine dlasrt2
