libflame
revision_anchor
|
Functions | |
int | zunmqr_fla (char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork, integer *info) |
int zunmqr_fla | ( | char * | side, |
char * | trans, | ||
integer * | m, | ||
integer * | n, | ||
integer * | k, | ||
doublecomplex * | a, | ||
integer * | lda, | ||
doublecomplex * | tau, | ||
doublecomplex * | c__, | ||
integer * | ldc, | ||
doublecomplex * | work, | ||
integer * | lwork, | ||
integer * | info | ||
) |
References doublecomplex::i, doublecomplex::r, and zunm2r_fla().
Referenced by zunmtr_fla().
{ /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__4, i__5; char ch__1[2]; /* Builtin functions */ /* Subroutine */ /* Local variables */ integer i__; doublecomplex t[4160] /* was [65][64] */ ; integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; logical left; extern logical lsame_(char *, char *); integer nbmin, iinfo; extern /* Subroutine */ int zunm2r_fla(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, 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 *); logical notran; 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 .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L"); notran = lsame_(trans, "N"); lquery = *lwork == -1; /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { nq = *m; nw = *n; } else { nq = *n; nw = *m; } if (! left && ! lsame_(side, "R")) { *info = -1; } else if (! notran && ! lsame_(trans, "C")) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*lda < max(1,nq)) { *info = -7; } else if (*ldc < max(1,*m)) { *info = -10; } else if (*lwork < max(1,nw) && ! lquery) { *info = -12; } if (*info == 0) { /* Determine the block size. NB may be at most NBMAX, where NBMAX */ /* is used to define the local array T. */ /* Computing MIN */ i__1 = 64; i__2 = ilaenv_(&c__1, "ZUNMQR", ch__1, m, n, k, &c_n1); // , expr subst nb = min(i__1,i__2); lwkopt = max(1,nw) * nb; work[1].r = (doublereal) lwkopt; work[1].i = 0.; // , expr subst } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNMQR", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { work[1].r = 1.; work[1].i = 0.; // , expr subst return 0; } nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { iws = nw * nb; if (*lwork < iws) { nb = *lwork / ldwork; /* Computing MAX */ i__1 = 2; i__2 = ilaenv_(&c__2, "ZUNMQR", ch__1, m, n, k, &c_n1); // , expr subst nbmin = max(i__1,i__2); } } else { iws = nw; } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ zunm2r_fla(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo); } else { /* Use blocked code */ if (left && ! notran || ! left && notran) { i1 = 1; i2 = *k; i3 = nb; } else { i1 = (*k - 1) / nb * nb + 1; i2 = 1; i3 = -nb; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__4 = nb; i__5 = *k - i__ + 1; // , expr subst ib = min(i__4,i__5); /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ i__4 = nq - i__ + 1; zlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], t, &c__65) ; if (left) { /* H or H**H is applied to C(i:m,1:n) */ mi = *m - i__ + 1; ic = i__; } else { /* H or H**H is applied to C(1:m,i:n) */ ni = *n - i__ + 1; jc = i__; } /* Apply H or H**H */ zlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork); /* L10: */ } } work[1].r = (doublereal) lwkopt; work[1].i = 0.; // , expr subst return 0; /* End of ZUNMQR */ }