1 /* ./src_f77/ssgets.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
8 /* Common Block Declarations */
9
10 struct {
11 integer logfil, ndigit, mgetv0, msaupd, msaup2, msaitr, mseigt, msapps,
12 msgets, mseupd, mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets,
13 mneupd, mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd;
14 } debug_SSGETS;
15
16 #define debug_1 debug_SSGETS
17
18 struct {
19 integer nopx, nbx, nrorth, nitref, nrstrt;
20 real tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, tnaupd,
21 tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, tcaupd, tcaup2,
22 tcaitr, tceigh, tcgets, tcapps, tcconv, tmvopx, tmvbx, tgetv0,
23 titref, trvec;
24 } timing_SSGETS;
25
26 #define timing_1 timing_SSGETS
27
28 /* Table of constant values */
29
30 static logical c_true = TRUE_;
31 static integer c__1 = 1;
32
33 /* ----------------------------------------------------------------------- */
34 /* \BeginDoc */
35
36 /* \Name: ssgets */
37
38 /* \Description: */
39 /* Given the eigenvalues of the symmetric tridiagonal matrix H, */
40 /* computes the NP shifts AMU that are zeros of the polynomial of */
41 /* degree NP which filters out components of the unwanted eigenvectors */
42 /* corresponding to the AMU's based on some given criteria. */
43
44 /* NOTE: This is called even in the case of user specified shifts in */
45 /* order to sort the eigenvalues, and error bounds of H for later use. */
46
47 /* \Usage: */
48 /* call ssgets */
49 /* ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) */
50
51 /* \Arguments */
52 /* ISHIFT Integer. (INPUT) */
53 /* Method for selecting the implicit shifts at each iteration. */
54 /* ISHIFT = 0: user specified shifts */
55 /* ISHIFT = 1: exact shift with respect to the matrix H. */
56
57 /* WHICH Character*2. (INPUT) */
58 /* Shift selection criteria. */
59 /* 'LM' -> KEV eigenvalues of largest magnitude are retained. */
60 /* 'SM' -> KEV eigenvalues of smallest magnitude are retained. */
61 /* 'LA' -> KEV eigenvalues of largest value are retained. */
62 /* 'SA' -> KEV eigenvalues of smallest value are retained. */
63 /* 'BE' -> KEV eigenvalues, half from each end of the spectrum. */
64 /* If KEV is odd, compute one more from the high end. */
65
66 /* KEV Integer. (INPUT) */
67 /* KEV+NP is the size of the matrix H. */
68
69 /* NP Integer. (INPUT) */
70 /* Number of implicit shifts to be computed. */
71
72 /* RITZ Real array of length KEV+NP. (INPUT/OUTPUT) */
73 /* On INPUT, RITZ contains the eigenvalues of H. */
74 /* On OUTPUT, RITZ are sorted so that the unwanted eigenvalues */
75 /* are in the first NP locations and the wanted part is in */
76 /* the last KEV locations. When exact shifts are selected, the */
77 /* unwanted part corresponds to the shifts to be applied. */
78
79 /* BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) */
80 /* Error bounds corresponding to the ordering in RITZ. */
81
82 /* SHIFTS Real array of length NP. (INPUT/OUTPUT) */
83 /* On INPUT: contains the user specified shifts if ISHIFT = 0. */
84 /* On OUTPUT: contains the shifts sorted into decreasing order */
85 /* of magnitude with respect to the Ritz estimates contained in */
86 /* BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. */
87
88 /* \EndDoc */
89
90 /* ----------------------------------------------------------------------- */
91
92 /* \BeginLib */
93
94 /* \Local variables: */
95 /* xxxxxx real */
96
97 /* \Routines called: */
98 /* ssortr ARPACK utility sorting routine. */
99 /* ivout ARPACK utility routine that prints integers. */
100 /* second ARPACK utility routine for timing. */
101 /* svout ARPACK utility routine that prints vectors. */
102 /* scopy Level 1 BLAS that copies one vector to another. */
103 /* sswap Level 1 BLAS that swaps the contents of two vectors. */
104
105 /* \Author */
106 /* Danny Sorensen Phuong Vu */
107 /* Richard Lehoucq CRPC / Rice University */
108 /* Dept. of Computational & Houston, Texas */
109 /* Applied Mathematics */
110 /* Rice University */
111 /* Houston, Texas */
112
113 /* \Revision history: */
114 /* xx/xx/93: Version ' 2.1' */
115
116 /* \SCCS Information: @(#) */
117 /* FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 */
118
119 /* \Remarks */
120
121 /* \EndLib */
122
123 /* ----------------------------------------------------------------------- */
124
ssgets_(integer * ishift,char * which,integer * kev,integer * np,real * ritz,real * bounds,real * shifts,ftnlen which_len)125 /* Subroutine */ int ssgets_(integer *ishift, char *which, integer *kev,
126 integer *np, real *ritz, real *bounds, real *shifts, ftnlen which_len)
127 {
128 /* System generated locals */
129 integer i__1;
130
131 /* Builtin functions */
132 integer s_cmp(char *, char *, ftnlen, ftnlen);
133
134 /* Local variables */
135 static real t0, t1;
136 static integer kevd2;
137 extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
138 integer *), scopy_(integer *, real *, integer *, real *, integer *
139 ), ivout_(integer *, integer *, integer *, integer *, char *,
140 ftnlen), svout_(integer *, integer *, real *, integer *, char *,
141 ftnlen), second_(real *);
142 static integer msglvl;
143 extern /* Subroutine */ int ssortr_(char *, logical *, integer *, real *,
144 real *, ftnlen);
145
146
147 /* %----------------------------------------------------% */
148 /* | Include files for debugging and timing information | */
149 /* %----------------------------------------------------% */
150
151
152 /* \SCCS Information: @(#) */
153 /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
154
155 /* %---------------------------------% */
156 /* | See debug.doc for documentation | */
157 /* %---------------------------------% */
158
159 /* %------------------% */
160 /* | Scalar Arguments | */
161 /* %------------------% */
162
163 /* %--------------------------------% */
164 /* | See stat.doc for documentation | */
165 /* %--------------------------------% */
166
167 /* \SCCS Information: @(#) */
168 /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
169
170
171
172 /* %-----------------% */
173 /* | Array Arguments | */
174 /* %-----------------% */
175
176
177 /* %------------% */
178 /* | Parameters | */
179 /* %------------% */
180
181
182 /* %---------------% */
183 /* | Local Scalars | */
184 /* %---------------% */
185
186
187 /* %----------------------% */
188 /* | External Subroutines | */
189 /* %----------------------% */
190
191
192 /* %---------------------% */
193 /* | Intrinsic Functions | */
194 /* %---------------------% */
195
196
197 /* %-----------------------% */
198 /* | Executable Statements | */
199 /* %-----------------------% */
200
201 /* %-------------------------------% */
202 /* | Initialize timing statistics | */
203 /* | & message level for debugging | */
204 /* %-------------------------------% */
205
206 /* Parameter adjustments */
207 --shifts;
208 --bounds;
209 --ritz;
210
211 /* Function Body */
212 second_(&t0);
213 msglvl = debug_1.msgets;
214
215 if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
216
217 /* %-----------------------------------------------------% */
218 /* | Both ends of the spectrum are requested. | */
219 /* | Sort the eigenvalues into algebraically increasing | */
220 /* | order first then swap high end of the spectrum next | */
221 /* | to low end in appropriate locations. | */
222 /* | NOTE: when np < floor(kev/2) be careful not to swap | */
223 /* | overlapping locations. | */
224 /* %-----------------------------------------------------% */
225
226 i__1 = *kev + *np;
227 ssortr_("LA", &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2);
228 kevd2 = *kev / 2;
229 if (*kev > 1) {
230 i__1 = min(kevd2,*np);
231 sswap_(&i__1, &ritz[1], &c__1, &ritz[max(kevd2,*np) + 1], &c__1);
232 i__1 = min(kevd2,*np);
233 sswap_(&i__1, &bounds[1], &c__1, &bounds[max(kevd2,*np) + 1], &
234 c__1);
235 }
236
237 } else {
238
239 /* %----------------------------------------------------% */
240 /* | LM, SM, LA, SA case. | */
241 /* | Sort the eigenvalues of H into the desired order | */
242 /* | and apply the resulting order to BOUNDS. | */
243 /* | The eigenvalues are sorted so that the wanted part | */
244 /* | are always in the last KEV locations. | */
245 /* %----------------------------------------------------% */
246
247 i__1 = *kev + *np;
248 ssortr_(which, &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2);
249 }
250
251 if (*ishift == 1 && *np > 0) {
252
253 /* %-------------------------------------------------------% */
254 /* | Sort the unwanted Ritz values used as shifts so that | */
255 /* | the ones with largest Ritz estimates are first. | */
256 /* | This will tend to minimize the effects of the | */
257 /* | forward instability of the iteration when the shifts | */
258 /* | are applied in subroutine ssapps. | */
259 /* %-------------------------------------------------------% */
260
261 ssortr_("SM", &c_true, np, &bounds[1], &ritz[1], (ftnlen)2);
262 scopy_(np, &ritz[1], &c__1, &shifts[1], &c__1);
263 }
264
265 second_(&t1);
266 timing_1.tsgets += t1 - t0;
267
268 if (msglvl > 0) {
269 ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_sgets: KEV is",
270 (ftnlen)14);
271 ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_sgets: NP is", (
272 ftnlen)13);
273 i__1 = *kev + *np;
274 svout_(&debug_1.logfil, &i__1, &ritz[1], &debug_1.ndigit, "_sgets: E"
275 "igenvalues of current H matrix", (ftnlen)39);
276 i__1 = *kev + *np;
277 svout_(&debug_1.logfil, &i__1, &bounds[1], &debug_1.ndigit, "_sgets:"
278 " Associated Ritz estimates", (ftnlen)33);
279 }
280
281 return 0;
282
283 /* %---------------% */
284 /* | End of ssgets | */
285 /* %---------------% */
286
287 } /* ssgets_ */
288
289