/* Subroutine */ int claqp2_(integer *m, integer *n, integer *offset, complex *a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2, complex *work) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; real r__1; complex q__1; /* Builtin functions */ double sqrt(doublereal); void r_cnjg(complex *, complex *); double c_abs(complex *); /* Local variables */ integer i__, j, mn; complex aii; integer pvt; real temp, temp2, tol3z; extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * , integer *, complex *, complex *, integer *, complex *); integer offpi; extern /* Subroutine */ int cswap_(integer *, complex *, integer *, complex *, integer *); integer itemp; extern doublereal scnrm2_(integer *, complex *, integer *); extern /* Subroutine */ int clarfp_(integer *, complex *, complex *, integer *, complex *); extern doublereal slamch_(char *); extern integer isamax_(integer *, real *, integer *); /* -- LAPACK auxiliary routine (version 3.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLAQP2 computes a QR factorization with column pivoting of */ /* the block A(OFFSET+1:M,1:N). */ /* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* OFFSET (input) INTEGER */ /* The number of rows of the matrix A that must be pivoted */ /* but no factorized. OFFSET >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */ /* the triangular factor obtained; the elements in block */ /* A(OFFSET+1:M,1:N) below the diagonal, together with the */ /* array TAU, represent the orthogonal matrix Q as a product of */ /* elementary reflectors. Block A(1:OFFSET,1:N) has been */ /* accordingly pivoted, but no factorized. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* JPVT (input/output) INTEGER array, dimension (N) */ /* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ /* to the front of A*P (a leading column); if JPVT(i) = 0, */ /* the i-th column of A is a free column. */ /* On exit, if JPVT(i) = k, then the i-th column of A*P */ /* was the k-th column of A. */ /* TAU (output) COMPLEX array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors. */ /* VN1 (input/output) REAL array, dimension (N) */ /* The vector with the partial column norms. */ /* VN2 (input/output) REAL array, dimension (N) */ /* The vector with the exact column norms. */ /* WORK (workspace) COMPLEX array, dimension (N) */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ /* X. Sun, Computer Science Dept., Duke University, USA */ /* Partial column norm updating strategy modified by */ /* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ /* University of Zagreb, Croatia. */ /* June 2006. */ /* For more details see LAPACK Working Note 176. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --jpvt; --tau; --vn1; --vn2; --work; /* Function Body */ /* Computing MIN */ i__1 = *m - *offset; mn = min(i__1,*n); tol3z = sqrt(slamch_("Epsilon")); /* Compute factorization. */ i__1 = mn; for (i__ = 1; i__ <= i__1; ++i__) { offpi = *offset + i__; /* Determine ith pivot column and swap if necessary. */ i__2 = *n - i__ + 1; pvt = i__ - 1 + isamax_(&i__2, &vn1[i__], &c__1); if (pvt != i__) { cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & c__1); itemp = jpvt[pvt]; jpvt[pvt] = jpvt[i__]; jpvt[i__] = itemp; vn1[pvt] = vn1[i__]; vn2[pvt] = vn2[i__]; } /* Generate elementary reflector H(i). */ if (offpi < *m) { i__2 = *m - offpi + 1; clarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ * a_dim1], &c__1, &tau[i__]); } else { clarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], & c__1, &tau[i__]); } if (i__ < *n) { /* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */ i__2 = offpi + i__ * a_dim1; aii.r = a[i__2].r, aii.i = a[i__2].i; i__2 = offpi + i__ * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; i__2 = *m - offpi + 1; i__3 = *n - i__; r_cnjg(&q__1, &tau[i__]); clarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, & q__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]); i__2 = offpi + i__ * a_dim1; a[i__2].r = aii.r, a[i__2].i = aii.i; } /* Update partial column norms. */ i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { if (vn1[j] != 0.f) { /* NOTE: The following 4 lines follow from the analysis in */ /* Lapack Working Note 176. */ /* Computing 2nd power */ r__1 = c_abs(&a[offpi + j * a_dim1]) / vn1[j]; temp = 1.f - r__1 * r__1; temp = dmax(temp,0.f); /* Computing 2nd power */ r__1 = vn1[j] / vn2[j]; temp2 = temp * (r__1 * r__1); if (temp2 <= tol3z) { if (offpi < *m) { i__3 = *m - offpi; vn1[j] = scnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], & c__1); vn2[j] = vn1[j]; } else { vn1[j] = 0.f; vn2[j] = 0.f; } } else { vn1[j] *= sqrt(temp); } } /* L10: */ } /* L20: */ } return 0; /* End of CLAQP2 */ } /* claqp2_ */
/* Subroutine */ int cgelq2_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__, k; complex alpha; extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex * , integer *, complex *, complex *, integer *, complex *), clacgv_(integer *, complex *, integer *), clarfp_(integer *, complex *, complex *, integer *, complex *), xerbla_(char *, integer *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGELQ2 computes an LQ factorization of a complex m by n matrix A: */ /* A = L * Q. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, the elements on and below the diagonal of the array */ /* contain the m by min(m,n) lower trapezoidal matrix L (L is */ /* lower triangular if m <= n); the elements above the diagonal, */ /* with the array TAU, represent the unitary matrix Q as a */ /* product of elementary reflectors (see Further Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* TAU (output) COMPLEX array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) COMPLEX array, dimension (M) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */ /* A(i,i+1:n), and tau in TAU(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic 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; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CGELQ2", &i__1); return 0; } k = min(*m,*n); i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */ i__2 = *n - i__ + 1; clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; clarfp_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &tau[i__] ); if (i__ < *m) { /* Apply H(i) to A(i+1:m,i:n) from the right */ i__2 = i__ + i__ * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; i__2 = *m - i__; i__3 = *n - i__ + 1; clarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); } i__2 = i__ + i__ * a_dim1; a[i__2].r = alpha.r, a[i__2].i = alpha.i; i__2 = *n - i__ + 1; clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); /* L10: */ } return 0; /* End of CGELQ2 */ } /* cgelq2_ */
int cgeql2_(int *m, int *n, complex *a, int *lda, complex *tau, complex *work, int *info) { /* System generated locals */ int a_dim1, a_offset, i__1, i__2; complex q__1; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ int i__, k; complex alpha; extern int clarf_(char *, int *, int *, complex * , int *, complex *, complex *, int *, complex *), clarfp_(int *, complex *, complex *, int *, complex *), xerbla_(char *, int *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGEQL2 computes a QL factorization of a complex m by n matrix A: */ /* A = Q * L. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, if m >= n, the lower triangle of the subarray */ /* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */ /* if m <= n, the elements on and below the (n-m)-th */ /* superdiagonal contain the m by n lower trapezoidal matrix L; */ /* the remaining elements, with the array TAU, represent the */ /* unitary matrix Q as a product of elementary reflectors */ /* (see Further Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= MAX(1,M). */ /* TAU (output) COMPLEX array, dimension (MIN(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) COMPLEX array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(k) . . . H(2) H(1), where k = MIN(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */ /* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic 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; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < MAX(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CGEQL2", &i__1); return 0; } k = MIN(*m,*n); for (i__ = k; i__ >= 1; --i__) { /* Generate elementary reflector H(i) to annihilate */ /* A(1:m-k+i-1,n-k+i) */ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; alpha.r = a[i__1].r, alpha.i = a[i__1].i; i__1 = *m - k + i__; clarfp_(&i__1, &alpha, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &tau[ i__]); /* Apply H(i)' to A(1:m-k+i,1:n-k+i-1) from the left */ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; a[i__1].r = 1.f, a[i__1].i = 0.f; i__1 = *m - k + i__; i__2 = *n - k + i__ - 1; r_cnjg(&q__1, &tau[i__]); clarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, & q__1, &a[a_offset], lda, &work[1]); i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; a[i__1].r = alpha.r, a[i__1].i = alpha.i; /* L10: */ } return 0; /* End of CGEQL2 */ } /* cgeql2_ */
/* Subroutine */ int claqps_(integer *m, integer *n, integer *offset, integer *nb, integer *kb, complex *a, integer *lda, integer *jpvt, complex * tau, real *vn1, real *vn2, complex *auxv, complex *f, integer *ldf) { /* System generated locals */ integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3; real r__1, r__2; complex q__1; /* Local variables */ integer j, k, rk; complex akk; integer pvt; real temp, temp2, tol3z; integer itemp; integer lsticc; integer lastrk; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CLAQPS computes a step of QR factorization with column pivoting */ /* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */ /* NB columns from A starting from the row OFFSET+1, and updates all */ /* of the matrix with Blas-3 xGEMM. */ /* In some cases, due to catastrophic cancellations, it cannot */ /* factorize NB columns. Hence, the actual number of factorized */ /* columns is returned in KB. */ /* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0 */ /* OFFSET (input) INTEGER */ /* The number of rows of A that have been factorized in */ /* previous steps. */ /* NB (input) INTEGER */ /* The number of columns to factorize. */ /* KB (output) INTEGER */ /* The number of columns actually factorized. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, block A(OFFSET+1:M,1:KB) is the triangular */ /* factor obtained and block A(1:OFFSET,1:N) has been */ /* accordingly pivoted, but no factorized. */ /* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */ /* been updated. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* JPVT (input/output) INTEGER array, dimension (N) */ /* JPVT(I) = K <==> Column K of the full matrix A has been */ /* permuted into position I in AP. */ /* TAU (output) COMPLEX array, dimension (KB) */ /* The scalar factors of the elementary reflectors. */ /* VN1 (input/output) REAL array, dimension (N) */ /* The vector with the partial column norms. */ /* VN2 (input/output) REAL array, dimension (N) */ /* The vector with the exact column norms. */ /* AUXV (input/output) COMPLEX array, dimension (NB) */ /* Auxiliar vector. */ /* F (input/output) COMPLEX array, dimension (LDF,NB) */ /* Matrix F' = L*Y'*A. */ /* LDF (input) INTEGER */ /* The leading dimension of the array F. LDF >= max(1,N). */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ /* X. Sun, Computer Science Dept., Duke University, USA */ /* Partial column norm updating strategy modified by */ /* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ /* University of Zagreb, Croatia. */ /* June 2006. */ /* For more details see LAPACK Working Note 176. */ /* ===================================================================== */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --jpvt; --tau; --vn1; --vn2; --auxv; f_dim1 = *ldf; f_offset = 1 + f_dim1; f -= f_offset; /* Function Body */ /* Computing MIN */ i__1 = *m, i__2 = *n + *offset; lastrk = min(i__1,i__2); lsticc = 0; k = 0; tol3z = sqrt(slamch_("Epsilon")); /* Beginning of while loop. */ L10: if (k < *nb && lsticc == 0) { ++k; rk = *offset + k; /* Determine ith pivot column and swap if necessary */ i__1 = *n - k + 1; pvt = k - 1 + isamax_(&i__1, &vn1[k], &c__1); if (pvt != k) { cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); i__1 = k - 1; cswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf); itemp = jpvt[pvt]; jpvt[pvt] = jpvt[k]; jpvt[k] = itemp; vn1[pvt] = vn1[k]; vn2[pvt] = vn2[k]; } /* Apply previous Householder reflectors to column K: */ /* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */ if (k > 1) { i__1 = k - 1; for (j = 1; j <= i__1; ++j) { i__2 = k + j * f_dim1; r_cnjg(&q__1, &f[k + j * f_dim1]); f[i__2].r = q__1.r, f[i__2].i = q__1.i; } i__1 = *m - rk + 1; i__2 = k - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__1, &i__2, &q__1, &a[rk + a_dim1], lda, &f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1); i__1 = k - 1; for (j = 1; j <= i__1; ++j) { i__2 = k + j * f_dim1; r_cnjg(&q__1, &f[k + j * f_dim1]); f[i__2].r = q__1.r, f[i__2].i = q__1.i; } } /* Generate elementary reflector H(k). */ if (rk < *m) { i__1 = *m - rk + 1; clarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], & c__1, &tau[k]); } else { clarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, & tau[k]); } i__1 = rk + k * a_dim1; akk.r = a[i__1].r, akk.i = a[i__1].i; i__1 = rk + k * a_dim1; a[i__1].r = 1.f, a[i__1].i = 0.f; /* Compute Kth column of F: */ /* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */ if (k < *n) { i__1 = *m - rk + 1; i__2 = *n - k; cgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[ k + 1 + k * f_dim1], &c__1); } /* Padding F(1:K,K) with zeros. */ i__1 = k; for (j = 1; j <= i__1; ++j) { i__2 = j + k * f_dim1; f[i__2].r = 0.f, f[i__2].i = 0.f; } /* Incremental updating of F: */ /* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */ /* *A(RK:M,K). */ if (k > 1) { i__1 = *m - rk + 1; i__2 = k - 1; i__3 = k; q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &a[rk + a_dim1] , lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1); i__1 = k - 1; cgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, & auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1); } /* Update the current row of A: */ /* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */ if (k < *n) { i__1 = *n - k; q__1.r = -1.f, q__1.i = -0.f; cgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, & q__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, & c_b2, &a[rk + (k + 1) * a_dim1], lda); } /* Update partial column norms. */ if (rk < lastrk) { i__1 = *n; for (j = k + 1; j <= i__1; ++j) { if (vn1[j] != 0.f) { /* NOTE: The following 4 lines follow from the analysis in */ /* Lapack Working Note 176. */ temp = c_abs(&a[rk + j * a_dim1]) / vn1[j]; /* Computing MAX */ r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp); temp = dmax(r__1,r__2); /* Computing 2nd power */ r__1 = vn1[j] / vn2[j]; temp2 = temp * (r__1 * r__1); if (temp2 <= tol3z) { vn2[j] = (real) lsticc; lsticc = j; } else { vn1[j] *= sqrt(temp); } } } } i__1 = rk + k * a_dim1; a[i__1].r = akk.r, a[i__1].i = akk.i; /* End of while loop. */ goto L10; } *kb = k; rk = *offset + *kb; /* Apply the block reflector to the rest of the matrix: */ /* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */ /* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */ /* Computing MIN */ i__1 = *n, i__2 = *m - *offset; if (*kb < min(i__1,i__2)) { i__1 = *m - rk; i__2 = *n - *kb; q__1.r = -1.f, q__1.i = -0.f; cgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &q__1, &a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, & a[rk + 1 + (*kb + 1) * a_dim1], lda); } /* Recomputation of difficult columns. */ L60: if (lsticc > 0) { itemp = i_nint(&vn2[lsticc]); i__1 = *m - rk; vn1[lsticc] = scnrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1); /* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ /* SNRM2 does not fail on vectors with norm below the value of */ /* SQRT(DLAMCH('S')) */ vn2[lsticc] = vn1[lsticc]; lsticc = itemp; goto L60; } return 0; /* End of CLAQPS */ } /* claqps_ */
int clatrz_(int *m, int *n, int *l, complex *a, int *lda, complex *tau, complex *work) { /* System generated locals */ int a_dim1, a_offset, i__1, i__2; complex q__1; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ int i__; complex alpha; extern int clarz_(char *, int *, int *, int * , complex *, int *, complex *, complex *, int *, complex * ), clacgv_(int *, complex *, int *), clarfp_( int *, complex *, complex *, int *, complex *); /* -- LAPACK routine (version 3.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix */ /* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means */ /* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary */ /* matrix and, R and A1 are M-by-M upper triangular matrices. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* L (input) INTEGER */ /* The number of columns of the matrix A containing the */ /* meaningful part of the Householder vectors. N-M >= L >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the leading M-by-N upper trapezoidal part of the */ /* array A must contain the matrix to be factorized. */ /* On exit, the leading M-by-M upper triangular part of A */ /* contains the upper triangular matrix R, and elements N-L+1 to */ /* N of the first M rows of A, with the array TAU, represent the */ /* unitary matrix Z as a product of M elementary reflectors. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= MAX(1,M). */ /* TAU (output) COMPLEX array, dimension (M) */ /* The scalar factors of the elementary reflectors. */ /* WORK (workspace) COMPLEX array, dimension (M) */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ /* The factorization is obtained by Householder's method. The kth */ /* transformation matrix, Z( k ), which is used to introduce zeros into */ /* the ( m - k + 1 )th row of A, is given in the form */ /* Z( k ) = ( I 0 ), */ /* ( 0 T( k ) ) */ /* where */ /* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */ /* ( 0 ) */ /* ( z( k ) ) */ /* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */ /* are chosen to annihilate the elements of the kth row of A2. */ /* The scalar tau is returned in the kth element of TAU and the vector */ /* u( k ) in the kth row of A2, such that the elements of z( k ) are */ /* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */ /* the upper triangular part of A1. */ /* Z is given by */ /* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick return if possible */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; --work; /* Function Body */ if (*m == 0) { return 0; } else if (*m == *n) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; tau[i__2].r = 0.f, tau[i__2].i = 0.f; /* L10: */ } return 0; } for (i__ = *m; i__ >= 1; --i__) { /* Generate elementary reflector H(i) to annihilate */ /* [ A(i,i) A(i,n-l+1:n) ] */ clacgv_(l, &a[i__ + (*n - *l + 1) * a_dim1], lda); r_cnjg(&q__1, &a[i__ + i__ * a_dim1]); alpha.r = q__1.r, alpha.i = q__1.i; i__1 = *l + 1; clarfp_(&i__1, &alpha, &a[i__ + (*n - *l + 1) * a_dim1], lda, &tau[ i__]); i__1 = i__; r_cnjg(&q__1, &tau[i__]); tau[i__1].r = q__1.r, tau[i__1].i = q__1.i; /* Apply H(i) to A(1:i-1,i:n) from the right */ i__1 = i__ - 1; i__2 = *n - i__ + 1; r_cnjg(&q__1, &tau[i__]); clarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1], lda, &q__1, &a[i__ * a_dim1 + 1], lda, &work[1]); i__1 = i__ + i__ * a_dim1; r_cnjg(&q__1, &alpha); a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* L20: */ } return 0; /* End of CLATRZ */ } /* clatrz_ */
/* Subroutine */ int cgerq2_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; /* Local variables */ integer i__, k; complex alpha; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CGERQ2 computes an RQ factorization of a complex m by n matrix A: */ /* A = R * Q. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, if m <= n, the upper triangle of the subarray */ /* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */ /* if m >= n, the elements on and above the (m-n)-th subdiagonal */ /* contain the m by n upper trapezoidal matrix R; the remaining */ /* elements, with the array TAU, represent the unitary matrix */ /* Q as a product of elementary reflectors (see Further */ /* Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* TAU (output) COMPLEX array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) COMPLEX array, dimension (M) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */ /* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */ /* ===================================================================== */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CGERQ2", &i__1); return 0; } k = min(*m,*n); for (i__ = k; i__ >= 1; --i__) { /* Generate elementary reflector H(i) to annihilate */ /* A(m-k+i,1:n-k+i-1) */ i__1 = *n - k + i__; clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda); i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; alpha.r = a[i__1].r, alpha.i = a[i__1].i; i__1 = *n - k + i__; clarfp_(&i__1, &alpha, &a[*m - k + i__ + a_dim1], lda, &tau[i__]); /* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; a[i__1].r = 1.f, a[i__1].i = 0.f; i__1 = *m - k + i__ - 1; i__2 = *n - k + i__; clarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[ i__], &a[a_offset], lda, &work[1]); i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; a[i__1].r = alpha.r, a[i__1].i = alpha.i; i__1 = *n - k + i__ - 1; clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda); } return 0; /* End of CGERQ2 */ } /* cgerq2_ */