1 /* arpack/dsortr.f -- translated by f2c (version 20090411).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11 */
12
13 #ifdef __cplusplus
14 extern "C" {
15 #endif
16 #include "v3p_netlib.h"
17
18 /* ----------------------------------------------------------------------- */
19 /* \BeginDoc */
20
21 /* \Name: dsortr */
22
23 /* \Description: */
24 /* Sort the array X1 in the order specified by WHICH and optionally */
25 /* applies the permutation to the array X2. */
26
27 /* \Usage: */
28 /* call dsortr */
29 /* ( WHICH, APPLY, N, X1, X2 ) */
30
31 /* \Arguments */
32 /* WHICH Character*2. (Input) */
33 /* 'LM' -> X1 is sorted into increasing order of magnitude. */
34 /* 'SM' -> X1 is sorted into decreasing order of magnitude. */
35 /* 'LA' -> X1 is sorted into increasing order of algebraic. */
36 /* 'SA' -> X1 is sorted into decreasing order of algebraic. */
37
38 /* APPLY Logical. (Input) */
39 /* APPLY = .TRUE. -> apply the sorted order to X2. */
40 /* APPLY = .FALSE. -> do not apply the sorted order to X2. */
41
42 /* N Integer. (INPUT) */
43 /* Size of the arrays. */
44
45 /* X1 Double precision array of length N. (INPUT/OUTPUT) */
46 /* The array to be sorted. */
47
48 /* X2 Double precision array of length N. (INPUT/OUTPUT) */
49 /* Only referenced if APPLY = .TRUE. */
50
51 /* \EndDoc */
52
53 /* ----------------------------------------------------------------------- */
54
55 /* \BeginLib */
56
57 /* \Author */
58 /* Danny Sorensen Phuong Vu */
59 /* Richard Lehoucq CRPC / Rice University */
60 /* Dept. of Computational & Houston, Texas */
61 /* Applied Mathematics */
62 /* Rice University */
63 /* Houston, Texas */
64
65 /* \Revision history: */
66 /* 12/16/93: Version ' 2.1'. */
67 /* Adapted from the sort routine in LANSO. */
68
69 /* \SCCS Information: @(#) */
70 /* FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 */
71
72 /* \EndLib */
73
74 /* ----------------------------------------------------------------------- */
75
76 /*< subroutine dsortr (which, apply, n, x1, x2) >*/
dsortr_(char * which,logical * apply,integer * n,doublereal * x1,doublereal * x2,ftnlen which_len)77 /* Subroutine */ int dsortr_(char *which, logical *apply, integer *n,
78 doublereal *x1, doublereal *x2, ftnlen which_len)
79 {
80 /* System generated locals */
81 integer i__1;
82 doublereal d__1, d__2;
83
84 /* Builtin functions */
85 integer s_cmp(char *, char *, ftnlen, ftnlen);
86
87 /* Local variables */
88 integer i__, j, igap;
89 doublereal temp;
90
91
92 /* %------------------% */
93 /* | Scalar Arguments | */
94 /* %------------------% */
95
96 /*< character*2 which >*/
97 /*< logical apply >*/
98 /*< integer n >*/
99
100 /* %-----------------% */
101 /* | Array Arguments | */
102 /* %-----------------% */
103
104 /*< >*/
105
106 /* %---------------% */
107 /* | Local Scalars | */
108 /* %---------------% */
109
110 /*< integer i, igap, j >*/
111 /*< >*/
112
113 /* %-----------------------% */
114 /* | Executable Statements | */
115 /* %-----------------------% */
116
117 /*< igap = n / 2 >*/
118 igap = *n / 2;
119
120 /*< if (which .eq. 'SA') then >*/
121 if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) {
122
123 /* X1 is sorted into decreasing order of algebraic. */
124
125 /*< 10 continue >*/
126 L10:
127 /*< if (igap .eq. 0) go to 9000 >*/
128 if (igap == 0) {
129 goto L9000;
130 }
131 /*< do 30 i = igap, n-1 >*/
132 i__1 = *n - 1;
133 for (i__ = igap; i__ <= i__1; ++i__) {
134 /*< j = i-igap >*/
135 j = i__ - igap;
136 /*< 20 continue >*/
137 L20:
138
139 /*< if (j.lt.0) go to 30 >*/
140 if (j < 0) {
141 goto L30;
142 }
143
144 /*< if (x1(j).lt.x1(j+igap)) then >*/
145 if (x1[j] < x1[j + igap]) {
146 /*< temp = x1(j) >*/
147 temp = x1[j];
148 /*< x1(j) = x1(j+igap) >*/
149 x1[j] = x1[j + igap];
150 /*< x1(j+igap) = temp >*/
151 x1[j + igap] = temp;
152 /*< if (apply) then >*/
153 if (*apply) {
154 /*< temp = x2(j) >*/
155 temp = x2[j];
156 /*< x2(j) = x2(j+igap) >*/
157 x2[j] = x2[j + igap];
158 /*< x2(j+igap) = temp >*/
159 x2[j + igap] = temp;
160 /*< end if >*/
161 }
162 /*< else >*/
163 } else {
164 /*< go to 30 >*/
165 goto L30;
166 /*< endif >*/
167 }
168 /*< j = j-igap >*/
169 j -= igap;
170 /*< go to 20 >*/
171 goto L20;
172 /*< 30 continue >*/
173 L30:
174 ;
175 }
176 /*< igap = igap / 2 >*/
177 igap /= 2;
178 /*< go to 10 >*/
179 goto L10;
180
181 /*< else if (which .eq. 'SM') then >*/
182 } else if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
183
184 /* X1 is sorted into decreasing order of magnitude. */
185
186 /*< 40 continue >*/
187 L40:
188 /*< if (igap .eq. 0) go to 9000 >*/
189 if (igap == 0) {
190 goto L9000;
191 }
192 /*< do 60 i = igap, n-1 >*/
193 i__1 = *n - 1;
194 for (i__ = igap; i__ <= i__1; ++i__) {
195 /*< j = i-igap >*/
196 j = i__ - igap;
197 /*< 50 continue >*/
198 L50:
199
200 /*< if (j.lt.0) go to 60 >*/
201 if (j < 0) {
202 goto L60;
203 }
204
205 /*< if (abs(x1(j)).lt.abs(x1(j+igap))) then >*/
206 if ((d__1 = x1[j], abs(d__1)) < (d__2 = x1[j + igap], abs(d__2)))
207 {
208 /*< temp = x1(j) >*/
209 temp = x1[j];
210 /*< x1(j) = x1(j+igap) >*/
211 x1[j] = x1[j + igap];
212 /*< x1(j+igap) = temp >*/
213 x1[j + igap] = temp;
214 /*< if (apply) then >*/
215 if (*apply) {
216 /*< temp = x2(j) >*/
217 temp = x2[j];
218 /*< x2(j) = x2(j+igap) >*/
219 x2[j] = x2[j + igap];
220 /*< x2(j+igap) = temp >*/
221 x2[j + igap] = temp;
222 /*< end if >*/
223 }
224 /*< else >*/
225 } else {
226 /*< go to 60 >*/
227 goto L60;
228 /*< endif >*/
229 }
230 /*< j = j-igap >*/
231 j -= igap;
232 /*< go to 50 >*/
233 goto L50;
234 /*< 60 continue >*/
235 L60:
236 ;
237 }
238 /*< igap = igap / 2 >*/
239 igap /= 2;
240 /*< go to 40 >*/
241 goto L40;
242
243 /*< else if (which .eq. 'LA') then >*/
244 } else if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) {
245
246 /* X1 is sorted into increasing order of algebraic. */
247
248 /*< 70 continue >*/
249 L70:
250 /*< if (igap .eq. 0) go to 9000 >*/
251 if (igap == 0) {
252 goto L9000;
253 }
254 /*< do 90 i = igap, n-1 >*/
255 i__1 = *n - 1;
256 for (i__ = igap; i__ <= i__1; ++i__) {
257 /*< j = i-igap >*/
258 j = i__ - igap;
259 /*< 80 continue >*/
260 L80:
261
262 /*< if (j.lt.0) go to 90 >*/
263 if (j < 0) {
264 goto L90;
265 }
266
267 /*< if (x1(j).gt.x1(j+igap)) then >*/
268 if (x1[j] > x1[j + igap]) {
269 /*< temp = x1(j) >*/
270 temp = x1[j];
271 /*< x1(j) = x1(j+igap) >*/
272 x1[j] = x1[j + igap];
273 /*< x1(j+igap) = temp >*/
274 x1[j + igap] = temp;
275 /*< if (apply) then >*/
276 if (*apply) {
277 /*< temp = x2(j) >*/
278 temp = x2[j];
279 /*< x2(j) = x2(j+igap) >*/
280 x2[j] = x2[j + igap];
281 /*< x2(j+igap) = temp >*/
282 x2[j + igap] = temp;
283 /*< end if >*/
284 }
285 /*< else >*/
286 } else {
287 /*< go to 90 >*/
288 goto L90;
289 /*< endif >*/
290 }
291 /*< j = j-igap >*/
292 j -= igap;
293 /*< go to 80 >*/
294 goto L80;
295 /*< 90 continue >*/
296 L90:
297 ;
298 }
299 /*< igap = igap / 2 >*/
300 igap /= 2;
301 /*< go to 70 >*/
302 goto L70;
303
304 /*< else if (which .eq. 'LM') then >*/
305 } else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
306
307 /* X1 is sorted into increasing order of magnitude. */
308
309 /*< 100 continue >*/
310 L100:
311 /*< if (igap .eq. 0) go to 9000 >*/
312 if (igap == 0) {
313 goto L9000;
314 }
315 /*< do 120 i = igap, n-1 >*/
316 i__1 = *n - 1;
317 for (i__ = igap; i__ <= i__1; ++i__) {
318 /*< j = i-igap >*/
319 j = i__ - igap;
320 /*< 110 continue >*/
321 L110:
322
323 /*< if (j.lt.0) go to 120 >*/
324 if (j < 0) {
325 goto L120;
326 }
327
328 /*< if (abs(x1(j)).gt.abs(x1(j+igap))) then >*/
329 if ((d__1 = x1[j], abs(d__1)) > (d__2 = x1[j + igap], abs(d__2)))
330 {
331 /*< temp = x1(j) >*/
332 temp = x1[j];
333 /*< x1(j) = x1(j+igap) >*/
334 x1[j] = x1[j + igap];
335 /*< x1(j+igap) = temp >*/
336 x1[j + igap] = temp;
337 /*< if (apply) then >*/
338 if (*apply) {
339 /*< temp = x2(j) >*/
340 temp = x2[j];
341 /*< x2(j) = x2(j+igap) >*/
342 x2[j] = x2[j + igap];
343 /*< x2(j+igap) = temp >*/
344 x2[j + igap] = temp;
345 /*< end if >*/
346 }
347 /*< else >*/
348 } else {
349 /*< go to 120 >*/
350 goto L120;
351 /*< endif >*/
352 }
353 /*< j = j-igap >*/
354 j -= igap;
355 /*< go to 110 >*/
356 goto L110;
357 /*< 120 continue >*/
358 L120:
359 ;
360 }
361 /*< igap = igap / 2 >*/
362 igap /= 2;
363 /*< go to 100 >*/
364 goto L100;
365 /*< end if >*/
366 }
367
368 /*< 9000 continue >*/
369 L9000:
370 /*< return >*/
371 return 0;
372
373 /* %---------------% */
374 /* | End of dsortr | */
375 /* %---------------% */
376
377 /*< end >*/
378 } /* dsortr_ */
379
380 #ifdef __cplusplus
381 }
382 #endif
383