libflame
revision_anchor
|
Functions | |
int | zungqr_fla (integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info) |
int zungqr_fla | ( | integer * | m, |
integer * | n, | ||
integer * | k, | ||
doublecomplex * | a, | ||
integer * | lda, | ||
doublecomplex * | tau, | ||
doublecomplex * | work, | ||
integer * | lwork, | ||
integer * | info | ||
) |
References doublecomplex::i, doublecomplex::r, and zung2r_fla().
Referenced by zungtr_fla().
{ /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; extern /* Subroutine */ int zung2r_fla(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); integer ldwork; extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); integer lwkopt; logical lquery; /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1); lwkopt = max(1,*n) * nb; work[1].r = (doublereal) lwkopt; work[1].i = 0.; // , expr subst lquery = *lwork == -1; if (*m < 0) { *info = -1; } else if (*n < 0 || *n > *m) { *info = -2; } else if (*k < 0 || *k > *n) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } else if (*lwork < max(1,*n) && ! lquery) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNGQR", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n <= 0) { work[1].r = 1.; work[1].i = 0.; // , expr subst return 0; } nbmin = 2; nx = 0; iws = *n; if (nb > 1 && nb < *k) { /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ i__1 = 0; i__2 = ilaenv_(&c__3, "ZUNGQR", " ", m, n, k, &c_n1); // , expr subst nx = max(i__1,i__2); if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ ldwork = *n; iws = ldwork * nb; if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ nb = *lwork / ldwork; /* Computing MAX */ i__1 = 2; i__2 = ilaenv_(&c__2, "ZUNGQR", " ", m, n, k, &c_n1); // , expr subst nbmin = max(i__1,i__2); } } } if (nb >= nbmin && nb < *k && nx < *k) { /* Use blocked code after the last block. */ /* The first kk columns are handled by the block method. */ ki = (*k - nx - 1) / nb * nb; /* Computing MIN */ i__1 = *k; i__2 = ki + nb; // , expr subst kk = min(i__1,i__2); /* Set A(1:kk,kk+1:n) to zero. */ i__1 = *n; for (j = kk + 1; j <= i__1; ++j) { i__2 = kk; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0.; a[i__3].i = 0.; // , expr subst /* L10: */ } /* L20: */ } } else { kk = 0; } /* Use unblocked code for the last or only block. */ if (kk < *n) { i__1 = *m - kk; i__2 = *n - kk; i__3 = *k - kk; zung2r_fla(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & tau[kk + 1], &work[1], &iinfo); } if (kk > 0) { /* Use blocked code */ i__1 = -nb; for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { /* Computing MIN */ i__2 = nb; i__3 = *k - i__ + 1; // , expr subst ib = min(i__2,i__3); if (i__ + ib <= *n) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ i__2 = *m - i__ + 1; zlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork); /* Apply H to A(i:m,i+ib:n) from the left */ i__2 = *m - i__ + 1; i__3 = *n - i__ - ib + 1; zlarfb_("Left", "No transpose", "Forward", "Columnwise", & i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & work[ib + 1], &ldwork); } /* Apply H to rows i:m of current block */ i__2 = *m - i__ + 1; zung2r_fla(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & work[1], &iinfo); /* Set rows 1:i-1 of current block to zero */ i__2 = i__ + ib - 1; for (j = i__; j <= i__2; ++j) { i__3 = i__ - 1; for (l = 1; l <= i__3; ++l) { i__4 = l + j * a_dim1; a[i__4].r = 0.; a[i__4].i = 0.; // , expr subst /* L30: */ } /* L40: */ } /* L50: */ } } work[1].r = (doublereal) iws; work[1].i = 0.; // , expr subst return 0; /* End of ZUNGQR */ }