1 /* ./src_f77/ssbevd.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 /* Table of constant values */
9
10 static real c_b11 = 1.f;
11 static real c_b18 = 0.f;
12 static integer c__1 = 1;
13
ssbevd_(char * jobz,char * uplo,integer * n,integer * kd,real * ab,integer * ldab,real * w,real * z__,integer * ldz,real * work,integer * lwork,integer * iwork,integer * liwork,integer * info,ftnlen jobz_len,ftnlen uplo_len)14 /* Subroutine */ int ssbevd_(char *jobz, char *uplo, integer *n, integer *kd,
15 real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work,
16 integer *lwork, integer *iwork, integer *liwork, integer *info,
17 ftnlen jobz_len, ftnlen uplo_len)
18 {
19 /* System generated locals */
20 integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
21 real r__1;
22
23 /* Builtin functions */
24 double sqrt(doublereal);
25
26 /* Local variables */
27 static real eps;
28 static integer inde;
29 static real anrm, rmin, rmax, sigma;
30 extern logical lsame_(char *, char *, ftnlen, ftnlen);
31 static integer iinfo;
32 extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
33 sgemm_(char *, char *, integer *, integer *, integer *, real *,
34 real *, integer *, real *, integer *, real *, real *, integer *,
35 ftnlen, ftnlen);
36 static integer lwmin;
37 static logical lower, wantz;
38 static integer indwk2, llwrk2, iscale;
39 extern doublereal slamch_(char *, ftnlen);
40 static real safmin;
41 extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
42 static real bignum;
43 extern doublereal slansb_(char *, char *, integer *, integer *, real *,
44 integer *, real *, ftnlen, ftnlen);
45 extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
46 real *, integer *, integer *, real *, integer *, integer *,
47 ftnlen), sstedc_(char *, integer *, real *, real *, real *,
48 integer *, real *, integer *, integer *, integer *, integer *,
49 ftnlen), slacpy_(char *, integer *, integer *, real *, integer *,
50 real *, integer *, ftnlen);
51 static integer indwrk, liwmin;
52 extern /* Subroutine */ int ssbtrd_(char *, char *, integer *, integer *,
53 real *, integer *, real *, real *, real *, integer *, real *,
54 integer *, ftnlen, ftnlen), ssterf_(integer *, real *, real *,
55 integer *);
56 static real smlnum;
57 static logical lquery;
58
59
60 /* -- LAPACK driver routine (version 3.0) -- */
61 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
62 /* Courant Institute, Argonne National Lab, and Rice University */
63 /* June 30, 1999 */
64
65 /* .. Scalar Arguments .. */
66 /* .. */
67 /* .. Array Arguments .. */
68 /* .. */
69
70 /* Purpose */
71 /* ======= */
72
73 /* SSBEVD computes all the eigenvalues and, optionally, eigenvectors of */
74 /* a real symmetric band matrix A. If eigenvectors are desired, it uses */
75 /* a divide and conquer algorithm. */
76
77 /* The divide and conquer algorithm makes very mild assumptions about */
78 /* floating point arithmetic. It will work on machines with a guard */
79 /* digit in add/subtract, or on those binary machines without guard */
80 /* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
81 /* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
82 /* without guard digits, but we know of none. */
83
84 /* Arguments */
85 /* ========= */
86
87 /* JOBZ (input) CHARACTER*1 */
88 /* = 'N': Compute eigenvalues only; */
89 /* = 'V': Compute eigenvalues and eigenvectors. */
90
91 /* UPLO (input) CHARACTER*1 */
92 /* = 'U': Upper triangle of A is stored; */
93 /* = 'L': Lower triangle of A is stored. */
94
95 /* N (input) INTEGER */
96 /* The order of the matrix A. N >= 0. */
97
98 /* KD (input) INTEGER */
99 /* The number of superdiagonals of the matrix A if UPLO = 'U', */
100 /* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
101
102 /* AB (input/output) REAL array, dimension (LDAB, N) */
103 /* On entry, the upper or lower triangle of the symmetric band */
104 /* matrix A, stored in the first KD+1 rows of the array. The */
105 /* j-th column of A is stored in the j-th column of the array AB */
106 /* as follows: */
107 /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
108 /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
109
110 /* On exit, AB is overwritten by values generated during the */
111 /* reduction to tridiagonal form. If UPLO = 'U', the first */
112 /* superdiagonal and the diagonal of the tridiagonal matrix T */
113 /* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
114 /* the diagonal and first subdiagonal of T are returned in the */
115 /* first two rows of AB. */
116
117 /* LDAB (input) INTEGER */
118 /* The leading dimension of the array AB. LDAB >= KD + 1. */
119
120 /* W (output) REAL array, dimension (N) */
121 /* If INFO = 0, the eigenvalues in ascending order. */
122
123 /* Z (output) REAL array, dimension (LDZ, N) */
124 /* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
125 /* eigenvectors of the matrix A, with the i-th column of Z */
126 /* holding the eigenvector associated with W(i). */
127 /* If JOBZ = 'N', then Z is not referenced. */
128
129 /* LDZ (input) INTEGER */
130 /* The leading dimension of the array Z. LDZ >= 1, and if */
131 /* JOBZ = 'V', LDZ >= max(1,N). */
132
133 /* WORK (workspace/output) REAL array, */
134 /* dimension (LWORK) */
135 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
136
137 /* LWORK (input) INTEGER */
138 /* The dimension of the array WORK. */
139 /* IF N <= 1, LWORK must be at least 1. */
140 /* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. */
141 /* If JOBZ = 'V' and N > 2, LWORK must be at least */
142 /* ( 1 + 5*N + 2*N**2 ). */
143
144 /* If LWORK = -1, then a workspace query is assumed; the routine */
145 /* only calculates the optimal size of the WORK array, returns */
146 /* this value as the first entry of the WORK array, and no error */
147 /* message related to LWORK is issued by XERBLA. */
148
149 /* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
150 /* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
151
152 /* LIWORK (input) INTEGER */
153 /* The dimension of the array LIWORK. */
154 /* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
155 /* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */
156
157 /* If LIWORK = -1, then a workspace query is assumed; the */
158 /* routine only calculates the optimal size of the IWORK array, */
159 /* returns this value as the first entry of the IWORK array, and */
160 /* no error message related to LIWORK is issued by XERBLA. */
161
162 /* INFO (output) INTEGER */
163 /* = 0: successful exit */
164 /* < 0: if INFO = -i, the i-th argument had an illegal value */
165 /* > 0: if INFO = i, the algorithm failed to converge; i */
166 /* off-diagonal elements of an intermediate tridiagonal */
167 /* form did not converge to zero. */
168
169 /* ===================================================================== */
170
171 /* .. Parameters .. */
172 /* .. */
173 /* .. Local Scalars .. */
174 /* .. */
175 /* .. External Functions .. */
176 /* .. */
177 /* .. External Subroutines .. */
178 /* .. */
179 /* .. Intrinsic Functions .. */
180 /* .. */
181 /* .. Executable Statements .. */
182
183 /* Test the input parameters. */
184
185 /* Parameter adjustments */
186 ab_dim1 = *ldab;
187 ab_offset = 1 + ab_dim1;
188 ab -= ab_offset;
189 --w;
190 z_dim1 = *ldz;
191 z_offset = 1 + z_dim1;
192 z__ -= z_offset;
193 --work;
194 --iwork;
195
196 /* Function Body */
197 wantz = lsame_(jobz, "V", (ftnlen)1, (ftnlen)1);
198 lower = lsame_(uplo, "L", (ftnlen)1, (ftnlen)1);
199 lquery = *lwork == -1 || *liwork == -1;
200
201 *info = 0;
202 if (*n <= 1) {
203 liwmin = 1;
204 lwmin = 1;
205 } else {
206 if (wantz) {
207 liwmin = *n * 5 + 3;
208 /* Computing 2nd power */
209 i__1 = *n;
210 lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
211 } else {
212 liwmin = 1;
213 lwmin = *n << 1;
214 }
215 }
216 if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
217 *info = -1;
218 } else if (! (lower || lsame_(uplo, "U", (ftnlen)1, (ftnlen)1))) {
219 *info = -2;
220 } else if (*n < 0) {
221 *info = -3;
222 } else if (*kd < 0) {
223 *info = -4;
224 } else if (*ldab < *kd + 1) {
225 *info = -6;
226 } else if (*ldz < 1 || wantz && *ldz < *n) {
227 *info = -9;
228 } else if (*lwork < lwmin && ! lquery) {
229 *info = -11;
230 } else if (*liwork < liwmin && ! lquery) {
231 *info = -13;
232 }
233
234 if (*info == 0) {
235 work[1] = (real) lwmin;
236 iwork[1] = liwmin;
237 }
238
239 if (*info != 0) {
240 i__1 = -(*info);
241 xerbla_("SSBEVD", &i__1, (ftnlen)6);
242 return 0;
243 } else if (lquery) {
244 return 0;
245 }
246
247 /* Quick return if possible */
248
249 if (*n == 0) {
250 return 0;
251 }
252
253 if (*n == 1) {
254 w[1] = ab[ab_dim1 + 1];
255 if (wantz) {
256 z__[z_dim1 + 1] = 1.f;
257 }
258 return 0;
259 }
260
261 /* Get machine constants. */
262
263 safmin = slamch_("Safe minimum", (ftnlen)12);
264 eps = slamch_("Precision", (ftnlen)9);
265 smlnum = safmin / eps;
266 bignum = 1.f / smlnum;
267 rmin = sqrt(smlnum);
268 rmax = sqrt(bignum);
269
270 /* Scale matrix to allowable range, if necessary. */
271
272 anrm = slansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1], (ftnlen)
273 1, (ftnlen)1);
274 iscale = 0;
275 if (anrm > 0.f && anrm < rmin) {
276 iscale = 1;
277 sigma = rmin / anrm;
278 } else if (anrm > rmax) {
279 iscale = 1;
280 sigma = rmax / anrm;
281 }
282 if (iscale == 1) {
283 if (lower) {
284 slascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
285 info, (ftnlen)1);
286 } else {
287 slascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
288 info, (ftnlen)1);
289 }
290 }
291
292 /* Call SSBTRD to reduce symmetric band matrix to tridiagonal form. */
293
294 inde = 1;
295 indwrk = inde + *n;
296 indwk2 = indwrk + *n * *n;
297 llwrk2 = *lwork - indwk2 + 1;
298 ssbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
299 z_offset], ldz, &work[indwrk], &iinfo, (ftnlen)1, (ftnlen)1);
300
301 /* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC. */
302
303 if (! wantz) {
304 ssterf_(n, &w[1], &work[inde], info);
305 } else {
306 sstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
307 llwrk2, &iwork[1], liwork, info, (ftnlen)1);
308 sgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk],
309 n, &c_b18, &work[indwk2], n, (ftnlen)1, (ftnlen)1);
310 slacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz, (ftnlen)1);
311 }
312
313 /* If matrix was scaled, then rescale eigenvalues appropriately. */
314
315 if (iscale == 1) {
316 r__1 = 1.f / sigma;
317 sscal_(n, &r__1, &w[1], &c__1);
318 }
319
320 work[1] = (real) lwmin;
321 iwork[1] = liwmin;
322 return 0;
323
324 /* End of SSBEVD */
325
326 } /* ssbevd_ */
327
328