Mercurial > octave-nkf

comparison libcruft/arpack/src/dsortr.f @ 12274:9f5d2ef078e8 release-3-4-x

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
import ARPACK sources to libcruft from Debian package libarpack2 2.1+parpack96.dfsg-3+b1
author John W. Eaton <jwe@octave.org>
date Fri, 28 Jan 2011 14:04:33 -0500
parents
children
comparison
equal deleted inserted replaced
12273:83133b5bf392 12274:9f5d2ef078e8
1 c-----------------------------------------------------------------------
2 c\BeginDoc
3 c
4 c\Name: dsortr
5 c
6 c\Description:
7 c Sort the array X1 in the order specified by WHICH and optionally
8 c applies the permutation to the array X2.
9 c
10 c\Usage:
11 c call dsortr
12 c ( WHICH, APPLY, N, X1, X2 )
13 c
14 c\Arguments
15 c WHICH Character*2. (Input)
16 c 'LM' -> X1 is sorted into increasing order of magnitude.
17 c 'SM' -> X1 is sorted into decreasing order of magnitude.
18 c 'LA' -> X1 is sorted into increasing order of algebraic.
19 c 'SA' -> X1 is sorted into decreasing order of algebraic.
20 c
21 c APPLY Logical. (Input)
22 c APPLY = .TRUE. -> apply the sorted order to X2.
23 c APPLY = .FALSE. -> do not apply the sorted order to X2.
24 c
25 c N Integer. (INPUT)
26 c Size of the arrays.
27 c
28 c X1 Double precision array of length N. (INPUT/OUTPUT)
29 c The array to be sorted.
30 c
31 c X2 Double precision array of length N. (INPUT/OUTPUT)
32 c Only referenced if APPLY = .TRUE.
33 c
34 c\EndDoc
35 c
36 c-----------------------------------------------------------------------
37 c
38 c\BeginLib
39 c
40 c\Author
41 c Danny Sorensen Phuong Vu
42 c Richard Lehoucq CRPC / Rice University
43 c Dept. of Computational & Houston, Texas
44 c Applied Mathematics
45 c Rice University
46 c Houston, Texas
47 c
48 c\Revision history:
49 c 12/16/93: Version ' 2.1'.
50 c Adapted from the sort routine in LANSO.
51 c
52 c\SCCS Information: @(#)
53 c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
54 c
55 c\EndLib
56 c
57 c-----------------------------------------------------------------------
58 c
59 subroutine dsortr (which, apply, n, x1, x2)
60 c
61 c %------------------%
62 c | Scalar Arguments |
63 c %------------------%
64 c
65 character*2 which
66 logical apply
67 integer n
68 c
69 c %-----------------%
70 c | Array Arguments |
71 c %-----------------%
72 c
73 Double precision
74 & x1(0:n-1), x2(0:n-1)
75 c
76 c %---------------%
77 c | Local Scalars |
78 c %---------------%
79 c
80 integer i, igap, j
81 Double precision
82 & temp
83 c
84 c %-----------------------%
85 c | Executable Statements |
86 c %-----------------------%
87 c
88 igap = n / 2
89 c
90 if (which .eq. 'SA') then
91 c
92 c X1 is sorted into decreasing order of algebraic.
93 c
94 10 continue
95 if (igap .eq. 0) go to 9000
96 do 30 i = igap, n-1
97 j = i-igap
98 20 continue
99 c
100 if (j.lt.0) go to 30
101 c
102 if (x1(j).lt.x1(j+igap)) then
103 temp = x1(j)
104 x1(j) = x1(j+igap)
105 x1(j+igap) = temp
106 if (apply) then
107 temp = x2(j)
108 x2(j) = x2(j+igap)
109 x2(j+igap) = temp
110 end if
111 else
112 go to 30
113 endif
114 j = j-igap
115 go to 20
116 30 continue
117 igap = igap / 2
118 go to 10
119 c
120 else if (which .eq. 'SM') then
121 c
122 c X1 is sorted into decreasing order of magnitude.
123 c
124 40 continue
125 if (igap .eq. 0) go to 9000
126 do 60 i = igap, n-1
127 j = i-igap
128 50 continue
129 c
130 if (j.lt.0) go to 60
131 c
132 if (abs(x1(j)).lt.abs(x1(j+igap))) then
133 temp = x1(j)
134 x1(j) = x1(j+igap)
135 x1(j+igap) = temp
136 if (apply) then
137 temp = x2(j)
138 x2(j) = x2(j+igap)
139 x2(j+igap) = temp
140 end if
141 else
142 go to 60
143 endif
144 j = j-igap
145 go to 50
146 60 continue
147 igap = igap / 2
148 go to 40
149 c
150 else if (which .eq. 'LA') then
151 c
152 c X1 is sorted into increasing order of algebraic.
153 c
154 70 continue
155 if (igap .eq. 0) go to 9000
156 do 90 i = igap, n-1
157 j = i-igap
158 80 continue
159 c
160 if (j.lt.0) go to 90
161 c
162 if (x1(j).gt.x1(j+igap)) then
163 temp = x1(j)
164 x1(j) = x1(j+igap)
165 x1(j+igap) = temp
166 if (apply) then
167 temp = x2(j)
168 x2(j) = x2(j+igap)
169 x2(j+igap) = temp
170 end if
171 else
172 go to 90
173 endif
174 j = j-igap
175 go to 80
176 90 continue
177 igap = igap / 2
178 go to 70
179 c
180 else if (which .eq. 'LM') then
181 c
182 c X1 is sorted into increasing order of magnitude.
183 c
184 100 continue
185 if (igap .eq. 0) go to 9000
186 do 120 i = igap, n-1
187 j = i-igap
188 110 continue
189 c
190 if (j.lt.0) go to 120
191 c
192 if (abs(x1(j)).gt.abs(x1(j+igap))) then
193 temp = x1(j)
194 x1(j) = x1(j+igap)
195 x1(j+igap) = temp
196 if (apply) then
197 temp = x2(j)
198 x2(j) = x2(j+igap)
199 x2(j+igap) = temp
200 end if
201 else
202 go to 120
203 endif
204 j = j-igap
205 go to 110
206 120 continue
207 igap = igap / 2
208 go to 100
209 end if
210 c
211 9000 continue
212 return
213 c
214 c %---------------%
215 c | End of dsortr |
216 c %---------------%
217 c
218 end