libflame  revision_anchor
Functions
chetrd.c File Reference

(r)

Functions

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

Function Documentation

◆ chetrd_fla()

int chetrd_fla ( char *  uplo,
integer n,
complex a,
integer lda,
real d__,
real e,
complex tau,
complex work,
integer lwork,
integer info 
)
193 {
194  /* System generated locals */
195  integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
196  complex q__1;
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 chetd2_fla(char *, integer *, complex *, integer *, real *, real *, complex *, integer *), cher2k_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, real *, complex *, integer *), clatrd_(char *, integer *, integer *, complex *, integer *, real *, complex *, complex *, integer *), xerbla_(char *, integer *);
204  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
205  integer ldwork, lwkopt;
206  logical lquery;
207  /* -- LAPACK computational routine (version 3.4.0) -- */
208  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
209  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
210  /* November 2011 */
211  /* .. Scalar Arguments .. */
212  /* .. */
213  /* .. Array Arguments .. */
214  /* .. */
215  /* ===================================================================== */
216  /* .. Parameters .. */
217  /* .. */
218  /* .. Local Scalars .. */
219  /* .. */
220  /* .. External Subroutines .. */
221  /* .. */
222  /* .. Intrinsic Functions .. */
223  /* .. */
224  /* .. External Functions .. */
225  /* .. */
226  /* .. Executable Statements .. */
227  /* Test the input parameters */
228  /* Parameter adjustments */
229  a_dim1 = *lda;
230  a_offset = 1 + a_dim1;
231  a -= a_offset;
232  --d__;
233  --e;
234  --tau;
235  --work;
236  /* Function Body */
237  *info = 0;
238  upper = lsame_(uplo, "U");
239  lquery = *lwork == -1;
240  if (! upper && ! lsame_(uplo, "L"))
241  {
242  *info = -1;
243  }
244  else if (*n < 0)
245  {
246  *info = -2;
247  }
248  else if (*lda < max(1,*n))
249  {
250  *info = -4;
251  }
252  else if (*lwork < 1 && ! lquery)
253  {
254  *info = -9;
255  }
256  if (*info == 0)
257  {
258  /* Determine the block size. */
259  nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
260  lwkopt = *n * nb;
261  work[1].r = (real) lwkopt;
262  work[1].i = 0.f; // , expr subst
263  }
264  if (*info != 0)
265  {
266  i__1 = -(*info);
267  xerbla_("CHETRD", &i__1);
268  return 0;
269  }
270  else if (lquery)
271  {
272  return 0;
273  }
274  /* Quick return if possible */
275  if (*n == 0)
276  {
277  work[1].r = 1.f;
278  work[1].i = 0.f; // , expr subst
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, "CHETRD", 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, "CHETRD", 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  clatrd_(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**H - W*V**H */
338  i__3 = i__ - 1;
339  q__1.r = -1.f;
340  q__1.i = -0.f; // , expr subst
341  cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &a[i__ * a_dim1 + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
342  /* Copy superdiagonal elements back into A, and diagonal */
343  /* elements into D */
344  i__3 = i__ + nb - 1;
345  for (j = i__;
346  j <= i__3;
347  ++j)
348  {
349  i__4 = j - 1 + j * a_dim1;
350  i__5 = j - 1;
351  a[i__4].r = e[i__5];
352  a[i__4].i = 0.f; // , expr subst
353  i__4 = j;
354  i__5 = j + j * a_dim1;
355  d__[i__4] = a[i__5].r;
356  /* L10: */
357  }
358  /* L20: */
359  }
360  /* Use unblocked code to reduce the last or only block */
361  chetd2_fla(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
362  }
363  else
364  {
365  /* Reduce the lower triangle of A */
366  i__2 = *n - nx;
367  i__1 = nb;
368  for (i__ = 1;
369  i__1 < 0 ? i__ >= i__2 : i__ <= i__2;
370  i__ += i__1)
371  {
372  /* Reduce columns i:i+nb-1 to tridiagonal form and form the */
373  /* matrix W which is needed to update the unreduced part of */
374  /* the matrix */
375  i__3 = *n - i__ + 1;
376  clatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & tau[i__], &work[1], &ldwork);
377  /* Update the unreduced submatrix A(i+nb:n,i+nb:n), using */
378  /* an update of the form: A := A - V*W**H - W*V**H */
379  i__3 = *n - i__ - nb + 1;
380  q__1.r = -1.f;
381  q__1.i = -0.f; // , expr subst
382  cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &a[i__ + nb + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ i__ + nb + (i__ + nb) * a_dim1], lda);
383  /* Copy subdiagonal elements back into A, and diagonal */
384  /* elements into D */
385  i__3 = i__ + nb - 1;
386  for (j = i__;
387  j <= i__3;
388  ++j)
389  {
390  i__4 = j + 1 + j * a_dim1;
391  i__5 = j;
392  a[i__4].r = e[i__5];
393  a[i__4].i = 0.f; // , expr subst
394  i__4 = j;
395  i__5 = j + j * a_dim1;
396  d__[i__4] = a[i__5].r;
397  /* L30: */
398  }
399  /* L40: */
400  }
401  /* Use unblocked code to reduce the last or only block */
402  i__1 = *n - i__ + 1;
403  chetd2_fla(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tau[i__], &iinfo);
404  }
405  work[1].r = (real) lwkopt;
406  work[1].i = 0.f; // , expr subst
407  return 0;
408  /* End of CHETRD */
409 }
int integer
Definition: FLA_f2c.h:25
int logical
Definition: FLA_f2c.h:36
float real
Definition: FLA_f2c.h:30
int chetd2_fla(char *uplo, integer *n, complex *a, integer *lda, real *d__, real *e, complex *tau, integer *info)
Definition: chetd2.c:174
Definition: FLA_f2c.h:32
real r
Definition: FLA_f2c.h:32
real i
Definition: FLA_f2c.h:32

References chetd2_fla().