libflame  revision_anchor
Functions
ssytrd.c File Reference

(r)

Functions

int ssytrd_fla (char *uplo, integer *n, real *a, integer *lda, real *d__, real *e, real *tau, real *work, integer *lwork, integer *info)
 

Function Documentation

◆ ssytrd_fla()

int ssytrd_fla ( char *  uplo,
integer n,
real a,
integer lda,
real d__,
real e,
real tau,
real work,
integer lwork,
integer info 
)

References ssytd2_fla().

194 {
195  /* System generated locals */
196  integer a_dim1, a_offset, i__1, i__2, i__3;
197  /* Local variables */
198  integer i__, j, nb, kk, nx, iws;
199  extern logical lsame_(char *, char *);
200  integer nbmin, iinfo;
201  logical upper;
202  extern /* Subroutine */
203  int ssytd2_fla(char *, integer *, real *, integer *, real *, real *, real *, integer *), ssyr2k_(char *, char * , integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *), xerbla_( char *, integer *);
204  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
205  extern /* Subroutine */
206  int slatrd_(char *, integer *, integer *, real *, integer *, real *, real *, real *, integer *);
207  integer ldwork, lwkopt;
208  logical lquery;
209  /* -- LAPACK computational routine (version 3.4.0) -- */
210  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
211  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
212  /* November 2011 */
213  /* .. Scalar Arguments .. */
214  /* .. */
215  /* .. Array Arguments .. */
216  /* .. */
217  /* ===================================================================== */
218  /* .. Parameters .. */
219  /* .. */
220  /* .. Local Scalars .. */
221  /* .. */
222  /* .. External Subroutines .. */
223  /* .. */
224  /* .. Intrinsic Functions .. */
225  /* .. */
226  /* .. External Functions .. */
227  /* .. */
228  /* .. Executable Statements .. */
229  /* Test the input parameters */
230  /* Parameter adjustments */
231  a_dim1 = *lda;
232  a_offset = 1 + a_dim1;
233  a -= a_offset;
234  --d__;
235  --e;
236  --tau;
237  --work;
238  /* Function Body */
239  *info = 0;
240  upper = lsame_(uplo, "U");
241  lquery = *lwork == -1;
242  if (! upper && ! lsame_(uplo, "L"))
243  {
244  *info = -1;
245  }
246  else if (*n < 0)
247  {
248  *info = -2;
249  }
250  else if (*lda < max(1,*n))
251  {
252  *info = -4;
253  }
254  else if (*lwork < 1 && ! lquery)
255  {
256  *info = -9;
257  }
258  if (*info == 0)
259  {
260  /* Determine the block size. */
261  nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
262  lwkopt = *n * nb;
263  work[1] = (real) lwkopt;
264  }
265  if (*info != 0)
266  {
267  i__1 = -(*info);
268  xerbla_("SSYTRD", &i__1);
269  return 0;
270  }
271  else if (lquery)
272  {
273  return 0;
274  }
275  /* Quick return if possible */
276  if (*n == 0)
277  {
278  work[1] = 1.f;
279  return 0;
280  }
281  nx = *n;
282  iws = 1;
283  if (nb > 1 && nb < *n)
284  {
285  /* Determine when to cross over from blocked to unblocked code */
286  /* (last block is always handled by unblocked code). */
287  /* Computing MAX */
288  i__1 = nb;
289  i__2 = ilaenv_(&c__3, "SSYTRD", uplo, n, &c_n1, &c_n1, & c_n1); // , expr subst
290  nx = max(i__1,i__2);
291  if (nx < *n)
292  {
293  /* Determine if workspace is large enough for blocked code. */
294  ldwork = *n;
295  iws = ldwork * nb;
296  if (*lwork < iws)
297  {
298  /* Not enough workspace to use optimal NB: determine the */
299  /* minimum value of NB, and reduce NB or force use of */
300  /* unblocked code by setting NX = N. */
301  /* Computing MAX */
302  i__1 = *lwork / ldwork;
303  nb = max(i__1,1);
304  nbmin = ilaenv_(&c__2, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
305  if (nb < nbmin)
306  {
307  nx = *n;
308  }
309  }
310  }
311  else
312  {
313  nx = *n;
314  }
315  }
316  else
317  {
318  nb = 1;
319  }
320  if (upper)
321  {
322  /* Reduce the upper triangle of A. */
323  /* Columns 1:kk are handled by the unblocked method. */
324  kk = *n - (*n - nx + nb - 1) / nb * nb;
325  i__1 = kk + 1;
326  i__2 = -nb;
327  for (i__ = *n - nb + 1;
328  i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
329  i__ += i__2)
330  {
331  /* Reduce columns i:i+nb-1 to tridiagonal form and form the */
332  /* matrix W which is needed to update the unreduced part of */
333  /* the matrix */
334  i__3 = i__ + nb - 1;
335  slatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & work[1], &ldwork);
336  /* Update the unreduced submatrix A(1:i-1,1:i-1), using an */
337  /* update of the form: A := A - V*W**T - W*V**T */
338  i__3 = i__ - 1;
339  ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
340  /* Copy superdiagonal elements back into A, and diagonal */
341  /* elements into D */
342  i__3 = i__ + nb - 1;
343  for (j = i__;
344  j <= i__3;
345  ++j)
346  {
347  a[j - 1 + j * a_dim1] = e[j - 1];
348  d__[j] = a[j + j * a_dim1];
349  /* L10: */
350  }
351  /* L20: */
352  }
353  /* Use unblocked code to reduce the last or only block */
354  ssytd2_fla(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
355  }
356  else
357  {
358  /* Reduce the lower triangle of A */
359  i__2 = *n - nx;
360  i__1 = nb;
361  for (i__ = 1;
362  i__1 < 0 ? i__ >= i__2 : i__ <= i__2;
363  i__ += i__1)
364  {
365  /* Reduce columns i:i+nb-1 to tridiagonal form and form the */
366  /* matrix W which is needed to update the unreduced part of */
367  /* the matrix */
368  i__3 = *n - i__ + 1;
369  slatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & tau[i__], &work[1], &ldwork);
370  /* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */
371  /* an update of the form: A := A - V*W**T - W*V**T */
372  i__3 = *n - i__ - nb + 1;
373  ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ i__ + nb + (i__ + nb) * a_dim1], lda);
374  /* Copy subdiagonal elements back into A, and diagonal */
375  /* elements into D */
376  i__3 = i__ + nb - 1;
377  for (j = i__;
378  j <= i__3;
379  ++j)
380  {
381  a[j + 1 + j * a_dim1] = e[j];
382  d__[j] = a[j + j * a_dim1];
383  /* L30: */
384  }
385  /* L40: */
386  }
387  /* Use unblocked code to reduce the last or only block */
388  i__1 = *n - i__ + 1;
389  ssytd2_fla(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tau[i__], &iinfo);
390  }
391  work[1] = (real) lwkopt;
392  return 0;
393  /* End of SSYTRD */
394 }
int ssytd2_fla(char *uplo, integer *n, real *a, integer *lda, real *d__, real *e, real *tau, integer *info)
Definition: ssytd2.c:169
float real
Definition: FLA_f2c.h:30
int logical
Definition: FLA_f2c.h:36
int integer
Definition: FLA_f2c.h:25