345 lines
9.0 KiB
Fortran
345 lines
9.0 KiB
Fortran
c-----------------------------------------------------------------------
|
|
c\BeginDoc
|
|
c
|
|
c\Name: dsortc
|
|
c
|
|
c\Description:
|
|
c Sorts the complex array in XREAL and XIMAG into the order
|
|
c specified by WHICH and optionally applies the permutation to the
|
|
c real array Y. It is assumed that if an element of XIMAG is
|
|
c nonzero, then its negative is also an element. In other words,
|
|
c both members of a complex conjugate pair are to be sorted and the
|
|
c pairs are kept adjacent to each other.
|
|
c
|
|
c\Usage:
|
|
c call dsortc
|
|
c ( WHICH, APPLY, N, XREAL, XIMAG, Y )
|
|
c
|
|
c\Arguments
|
|
c WHICH Character*2. (Input)
|
|
c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude.
|
|
c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude.
|
|
c 'LR' -> sort XREAL into increasing order of algebraic.
|
|
c 'SR' -> sort XREAL into decreasing order of algebraic.
|
|
c 'LI' -> sort XIMAG into increasing order of magnitude.
|
|
c 'SI' -> sort XIMAG into decreasing order of magnitude.
|
|
c NOTE: If an element of XIMAG is non-zero, then its negative
|
|
c is also an element.
|
|
c
|
|
c APPLY Logical. (Input)
|
|
c APPLY = .TRUE. -> apply the sorted order to array Y.
|
|
c APPLY = .FALSE. -> do not apply the sorted order to array Y.
|
|
c
|
|
c N Integer. (INPUT)
|
|
c Size of the arrays.
|
|
c
|
|
c XREAL, Double precision array of length N. (INPUT/OUTPUT)
|
|
c XIMAG Real and imaginary part of the array to be sorted.
|
|
c
|
|
c Y Double precision array of length N. (INPUT/OUTPUT)
|
|
c
|
|
c\EndDoc
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
c\BeginLib
|
|
c
|
|
c\Author
|
|
c Danny Sorensen Phuong Vu
|
|
c Richard Lehoucq CRPC / Rice University
|
|
c Dept. of Computational & Houston, Texas
|
|
c Applied Mathematics
|
|
c Rice University
|
|
c Houston, Texas
|
|
c
|
|
c\Revision history:
|
|
c xx/xx/92: Version ' 2.1'
|
|
c Adapted from the sort routine in LANSO.
|
|
c
|
|
c\SCCS Information: @(#)
|
|
c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
|
|
c
|
|
c\EndLib
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine dsortc (which, apply, n, xreal, ximag, y)
|
|
c
|
|
c %------------------%
|
|
c | Scalar Arguments |
|
|
c %------------------%
|
|
c
|
|
character*2 which
|
|
logical apply
|
|
integer n
|
|
c
|
|
c %-----------------%
|
|
c | Array Arguments |
|
|
c %-----------------%
|
|
c
|
|
Double precision
|
|
& xreal(0:n-1), ximag(0:n-1), y(0:n-1)
|
|
c
|
|
c %---------------%
|
|
c | Local Scalars |
|
|
c %---------------%
|
|
c
|
|
integer i, igap, j
|
|
Double precision
|
|
& temp, temp1, temp2
|
|
c
|
|
c %--------------------%
|
|
c | External Functions |
|
|
c %--------------------%
|
|
c
|
|
Double precision
|
|
& dlapy2
|
|
external dlapy2
|
|
c
|
|
c %-----------------------%
|
|
c | Executable Statements |
|
|
c %-----------------------%
|
|
c
|
|
igap = n / 2
|
|
c
|
|
if (which .eq. 'LM') then
|
|
c
|
|
c %------------------------------------------------------%
|
|
c | Sort XREAL,XIMAG into increasing order of magnitude. |
|
|
c %------------------------------------------------------%
|
|
c
|
|
10 continue
|
|
if (igap .eq. 0) go to 9000
|
|
c
|
|
do 30 i = igap, n-1
|
|
j = i-igap
|
|
20 continue
|
|
c
|
|
if (j.lt.0) go to 30
|
|
c
|
|
temp1 = dlapy2(xreal(j),ximag(j))
|
|
temp2 = dlapy2(xreal(j+igap),ximag(j+igap))
|
|
c
|
|
if (temp1.gt.temp2) then
|
|
temp = xreal(j)
|
|
xreal(j) = xreal(j+igap)
|
|
xreal(j+igap) = temp
|
|
c
|
|
temp = ximag(j)
|
|
ximag(j) = ximag(j+igap)
|
|
ximag(j+igap) = temp
|
|
c
|
|
if (apply) then
|
|
temp = y(j)
|
|
y(j) = y(j+igap)
|
|
y(j+igap) = temp
|
|
end if
|
|
else
|
|
go to 30
|
|
end if
|
|
j = j-igap
|
|
go to 20
|
|
30 continue
|
|
igap = igap / 2
|
|
go to 10
|
|
c
|
|
else if (which .eq. 'SM') then
|
|
c
|
|
c %------------------------------------------------------%
|
|
c | Sort XREAL,XIMAG into decreasing order of magnitude. |
|
|
c %------------------------------------------------------%
|
|
c
|
|
40 continue
|
|
if (igap .eq. 0) go to 9000
|
|
c
|
|
do 60 i = igap, n-1
|
|
j = i-igap
|
|
50 continue
|
|
c
|
|
if (j .lt. 0) go to 60
|
|
c
|
|
temp1 = dlapy2(xreal(j),ximag(j))
|
|
temp2 = dlapy2(xreal(j+igap),ximag(j+igap))
|
|
c
|
|
if (temp1.lt.temp2) then
|
|
temp = xreal(j)
|
|
xreal(j) = xreal(j+igap)
|
|
xreal(j+igap) = temp
|
|
c
|
|
temp = ximag(j)
|
|
ximag(j) = ximag(j+igap)
|
|
ximag(j+igap) = temp
|
|
c
|
|
if (apply) then
|
|
temp = y(j)
|
|
y(j) = y(j+igap)
|
|
y(j+igap) = temp
|
|
end if
|
|
else
|
|
go to 60
|
|
endif
|
|
j = j-igap
|
|
go to 50
|
|
60 continue
|
|
igap = igap / 2
|
|
go to 40
|
|
c
|
|
else if (which .eq. 'LR') then
|
|
c
|
|
c %------------------------------------------------%
|
|
c | Sort XREAL into increasing order of algebraic. |
|
|
c %------------------------------------------------%
|
|
c
|
|
70 continue
|
|
if (igap .eq. 0) go to 9000
|
|
c
|
|
do 90 i = igap, n-1
|
|
j = i-igap
|
|
80 continue
|
|
c
|
|
if (j.lt.0) go to 90
|
|
c
|
|
if (xreal(j).gt.xreal(j+igap)) then
|
|
temp = xreal(j)
|
|
xreal(j) = xreal(j+igap)
|
|
xreal(j+igap) = temp
|
|
c
|
|
temp = ximag(j)
|
|
ximag(j) = ximag(j+igap)
|
|
ximag(j+igap) = temp
|
|
c
|
|
if (apply) then
|
|
temp = y(j)
|
|
y(j) = y(j+igap)
|
|
y(j+igap) = temp
|
|
end if
|
|
else
|
|
go to 90
|
|
endif
|
|
j = j-igap
|
|
go to 80
|
|
90 continue
|
|
igap = igap / 2
|
|
go to 70
|
|
c
|
|
else if (which .eq. 'SR') then
|
|
c
|
|
c %------------------------------------------------%
|
|
c | Sort XREAL into decreasing order of algebraic. |
|
|
c %------------------------------------------------%
|
|
c
|
|
100 continue
|
|
if (igap .eq. 0) go to 9000
|
|
do 120 i = igap, n-1
|
|
j = i-igap
|
|
110 continue
|
|
c
|
|
if (j.lt.0) go to 120
|
|
c
|
|
if (xreal(j).lt.xreal(j+igap)) then
|
|
temp = xreal(j)
|
|
xreal(j) = xreal(j+igap)
|
|
xreal(j+igap) = temp
|
|
c
|
|
temp = ximag(j)
|
|
ximag(j) = ximag(j+igap)
|
|
ximag(j+igap) = temp
|
|
c
|
|
if (apply) then
|
|
temp = y(j)
|
|
y(j) = y(j+igap)
|
|
y(j+igap) = temp
|
|
end if
|
|
else
|
|
go to 120
|
|
endif
|
|
j = j-igap
|
|
go to 110
|
|
120 continue
|
|
igap = igap / 2
|
|
go to 100
|
|
c
|
|
else if (which .eq. 'LI') then
|
|
c
|
|
c %------------------------------------------------%
|
|
c | Sort XIMAG into increasing order of magnitude. |
|
|
c %------------------------------------------------%
|
|
c
|
|
130 continue
|
|
if (igap .eq. 0) go to 9000
|
|
do 150 i = igap, n-1
|
|
j = i-igap
|
|
140 continue
|
|
c
|
|
if (j.lt.0) go to 150
|
|
c
|
|
if (abs(ximag(j)).gt.abs(ximag(j+igap))) then
|
|
temp = xreal(j)
|
|
xreal(j) = xreal(j+igap)
|
|
xreal(j+igap) = temp
|
|
c
|
|
temp = ximag(j)
|
|
ximag(j) = ximag(j+igap)
|
|
ximag(j+igap) = temp
|
|
c
|
|
if (apply) then
|
|
temp = y(j)
|
|
y(j) = y(j+igap)
|
|
y(j+igap) = temp
|
|
end if
|
|
else
|
|
go to 150
|
|
endif
|
|
j = j-igap
|
|
go to 140
|
|
150 continue
|
|
igap = igap / 2
|
|
go to 130
|
|
c
|
|
else if (which .eq. 'SI') then
|
|
c
|
|
c %------------------------------------------------%
|
|
c | Sort XIMAG into decreasing order of magnitude. |
|
|
c %------------------------------------------------%
|
|
c
|
|
160 continue
|
|
if (igap .eq. 0) go to 9000
|
|
do 180 i = igap, n-1
|
|
j = i-igap
|
|
170 continue
|
|
c
|
|
if (j.lt.0) go to 180
|
|
c
|
|
if (abs(ximag(j)).lt.abs(ximag(j+igap))) then
|
|
temp = xreal(j)
|
|
xreal(j) = xreal(j+igap)
|
|
xreal(j+igap) = temp
|
|
c
|
|
temp = ximag(j)
|
|
ximag(j) = ximag(j+igap)
|
|
ximag(j+igap) = temp
|
|
c
|
|
if (apply) then
|
|
temp = y(j)
|
|
y(j) = y(j+igap)
|
|
y(j+igap) = temp
|
|
end if
|
|
else
|
|
go to 180
|
|
endif
|
|
j = j-igap
|
|
go to 170
|
|
180 continue
|
|
igap = igap / 2
|
|
go to 160
|
|
end if
|
|
c
|
|
9000 continue
|
|
return
|
|
c
|
|
c %---------------%
|
|
c | End of dsortc |
|
|
c %---------------%
|
|
c
|
|
end
|