libflame  revision_anchor
Functions
zhetrd.c File Reference

(r)

Functions

int zhetrd_fla (char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info)
 

Function Documentation

◆ zhetrd_fla()

int zhetrd_fla ( char *  uplo,
integer n,
doublecomplex a,
integer lda,
doublereal d__,
doublereal e,
doublecomplex tau,
doublecomplex 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  doublecomplex z__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 zhetd2_fla(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, integer *), zher2k_(char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *), xerbla_(char *, integer *);
204  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
205  extern /* Subroutine */
206  int zlatrd_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, doublecomplex *, 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, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
262  lwkopt = *n * nb;
263  work[1].r = (doublereal) lwkopt;
264  work[1].i = 0.; // , expr subst
265  }
266  if (*info != 0)
267  {
268  i__1 = -(*info);
269  xerbla_("ZHETRD", &i__1);
270  return 0;
271  }
272  else if (lquery)
273  {
274  return 0;
275  }
276  /* Quick return if possible */
277  if (*n == 0)
278  {
279  work[1].r = 1.;
280  work[1].i = 0.; // , expr subst
281  return 0;
282  }
283  nx = *n;
284  iws = 1;
285  if (nb > 1 && nb < *n)
286  {
287  /* Determine when to cross over from blocked to unblocked code */
288  /* (last block is always handled by unblocked code). */
289  /* Computing MAX */
290  i__1 = nb;
291  i__2 = ilaenv_(&c__3, "ZHETRD", uplo, n, &c_n1, &c_n1, & c_n1); // , expr subst
292  nx = max(i__1,i__2);
293  if (nx < *n)
294  {
295  /* Determine if workspace is large enough for blocked code. */
296  ldwork = *n;
297  iws = ldwork * nb;
298  if (*lwork < iws)
299  {
300  /* Not enough workspace to use optimal NB: determine the */
301  /* minimum value of NB, and reduce NB or force use of */
302  /* unblocked code by setting NX = N. */
303  /* Computing MAX */
304  i__1 = *lwork / ldwork;
305  nb = max(i__1,1);
306  nbmin = ilaenv_(&c__2, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
307  if (nb < nbmin)
308  {
309  nx = *n;
310  }
311  }
312  }
313  else
314  {
315  nx = *n;
316  }
317  }
318  else
319  {
320  nb = 1;
321  }
322  if (upper)
323  {
324  /* Reduce the upper triangle of A. */
325  /* Columns 1:kk are handled by the unblocked method. */
326  kk = *n - (*n - nx + nb - 1) / nb * nb;
327  i__1 = kk + 1;
328  i__2 = -nb;
329  for (i__ = *n - nb + 1;
330  i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
331  i__ += i__2)
332  {
333  /* Reduce columns i:i+nb-1 to tridiagonal form and form the */
334  /* matrix W which is needed to update the unreduced part of */
335  /* the matrix */
336  i__3 = i__ + nb - 1;
337  zlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & work[1], &ldwork);
338  /* Update the unreduced submatrix A(1:i-1,1:i-1), using an */
339  /* update of the form: A := A - V*W**H - W*V**H */
340  i__3 = i__ - 1;
341  z__1.r = -1.;
342  z__1.i = -0.; // , expr subst
343  zher2k_(uplo, "No transpose", &i__3, &nb, &z__1, &a[i__ * a_dim1 + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
344  /* Copy superdiagonal elements back into A, and diagonal */
345  /* elements into D */
346  i__3 = i__ + nb - 1;
347  for (j = i__;
348  j <= i__3;
349  ++j)
350  {
351  i__4 = j - 1 + j * a_dim1;
352  i__5 = j - 1;
353  a[i__4].r = e[i__5];
354  a[i__4].i = 0.; // , expr subst
355  i__4 = j;
356  i__5 = j + j * a_dim1;
357  d__[i__4] = a[i__5].r;
358  /* L10: */
359  }
360  /* L20: */
361  }
362  /* Use unblocked code to reduce the last or only block */
363  zhetd2_fla(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
364  }
365  else
366  {
367  /* Reduce the lower triangle of A */
368  i__2 = *n - nx;
369  i__1 = nb;
370  for (i__ = 1;
371  i__1 < 0 ? i__ >= i__2 : i__ <= i__2;
372  i__ += i__1)
373  {
374  /* Reduce columns i:i+nb-1 to tridiagonal form and form the */
375  /* matrix W which is needed to update the unreduced part of */
376  /* the matrix */
377  i__3 = *n - i__ + 1;
378  zlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & tau[i__], &work[1], &ldwork);
379  /* Update the unreduced submatrix A(i+nb:n,i+nb:n), using */
380  /* an update of the form: A := A - V*W**H - W*V**H */
381  i__3 = *n - i__ - nb + 1;
382  z__1.r = -1.;
383  z__1.i = -0.; // , expr subst
384  zher2k_(uplo, "No transpose", &i__3, &nb, &z__1, &a[i__ + nb + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ i__ + nb + (i__ + nb) * a_dim1], lda);
385  /* Copy subdiagonal elements back into A, and diagonal */
386  /* elements into D */
387  i__3 = i__ + nb - 1;
388  for (j = i__;
389  j <= i__3;
390  ++j)
391  {
392  i__4 = j + 1 + j * a_dim1;
393  i__5 = j;
394  a[i__4].r = e[i__5];
395  a[i__4].i = 0.; // , expr subst
396  i__4 = j;
397  i__5 = j + j * a_dim1;
398  d__[i__4] = a[i__5].r;
399  /* L30: */
400  }
401  /* L40: */
402  }
403  /* Use unblocked code to reduce the last or only block */
404  i__1 = *n - i__ + 1;
405  zhetd2_fla(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tau[i__], &iinfo);
406  }
407  work[1].r = (doublereal) lwkopt;
408  work[1].i = 0.; // , expr subst
409  return 0;
410  /* End of ZHETRD */
411 }
double doublereal
Definition: FLA_f2c.h:31
int integer
Definition: FLA_f2c.h:25
int logical
Definition: FLA_f2c.h:36
Definition: FLA_f2c.h:33
doublereal i
Definition: FLA_f2c.h:33
doublereal r
Definition: FLA_f2c.h:33
int zhetd2_fla(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, integer *info)
Definition: zhetd2.c:174

References zhetd2_fla().