int dtzrqf_(int *m, int *n, double *a, int * lda, double *tau, int *info) { /* System generated locals */ int a_dim1, a_offset, i__1, i__2; double d__1; /* Local variables */ int i__, k, m1; extern int dger_(int *, int *, double *, double *, int *, double *, int *, double *, int *), dgemv_(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *), dcopy_(int *, double *, int *, double *, int *), daxpy_(int *, double *, double *, int *, double *, int *), dlarfp_( int *, double *, double *, int *, double *), 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 */ /* ======= */ /* This routine is deprecated and has been replaced by routine DTZRZF. */ /* DTZRQF reduces the M-by-N ( M<=N ) float upper trapezoidal matrix A */ /* to upper triangular form by means of orthogonal transformations. */ /* The upper trapezoidal matrix A is factored as */ /* A = ( R 0 ) * Z, */ /* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ /* triangular matrix. */ /* 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 >= M. */ /* A (input/output) DOUBLE PRECISION 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 M+1 to */ /* N of the first M rows of A, with the array TAU, represent the */ /* orthogonal 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) DOUBLE PRECISION array, dimension (M) */ /* The scalar factors of the elementary reflectors. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* 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 ( n - m ) element vector. */ /* tau and z( k ) are chosen to annihilate the elements of the kth row */ /* of X. */ /* The scalar tau is returned in the kth element of TAU and the vector */ /* u( k ) in the kth row of A, such that the elements of z( k ) are */ /* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ /* the upper triangular part of A. */ /* Z is given by */ /* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < *m) { *info = -2; } else if (*lda < MAX(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("DTZRQF", &i__1); return 0; } /* Perform the factorization. */ if (*m == 0) { return 0; } if (*m == *n) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { tau[i__] = 0.; /* L10: */ } } else { /* Computing MIN */ i__1 = *m + 1; m1 = MIN(i__1,*n); for (k = *m; k >= 1; --k) { /* Use a Householder reflection to zero the kth row of A. */ /* First set up the reflection. */ i__1 = *n - *m + 1; dlarfp_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[ k]); if (tau[k] != 0. && k > 1) { /* We now perform the operation A := A*P( k ). */ /* Use the first ( k - 1 ) elements of TAU to store a( k ), */ /* where a( k ) consists of the first ( k - 1 ) elements of */ /* the kth column of A. Also let B denote the first */ /* ( k - 1 ) rows of the last ( n - m ) columns of A. */ i__1 = k - 1; dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1); /* Form w = a( k ) + B*z( k ) in TAU. */ i__1 = k - 1; i__2 = *n - *m; dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 + 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], & c__1); /* Now form a( k ) := a( k ) - tau*w */ /* and B := B - tau*w*z( k )'. */ i__1 = k - 1; d__1 = -tau[k]; daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & c__1); i__1 = k - 1; i__2 = *n - *m; d__1 = -tau[k]; dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1] , lda, &a[m1 * a_dim1 + 1], lda); } /* L20: */ } } return 0; /* End of DTZRQF */ } /* dtzrqf_ */
/* Subroutine */ int dgeql2_(integer *m, integer *n, doublereal *a, integer * lda, doublereal *tau, doublereal *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; /* Local variables */ integer i__, k; doublereal aii; extern /* Subroutine */ int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *), dlarfp_(integer *, doublereal *, doublereal *, integer *, doublereal *), 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 */ /* ======= */ /* DGEQL2 computes a QL factorization of a real 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) DOUBLE PRECISION 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 */ /* orthogonal 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) DOUBLE PRECISION array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) DOUBLE PRECISION 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 real scalar, and v is a real 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_("DGEQL2", &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__; dlarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &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 */ aii = a[*m - k + i__ + (*n - k + i__) * a_dim1]; a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.; i__1 = *m - k + i__; i__2 = *n - k + i__ - 1; dlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, & tau[i__], &a[a_offset], lda, &work[1]); a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii; /* L10: */ } return 0; /* End of DGEQL2 */ } /* dgeql2_ */
int dlaqps_(int *m, int *n, int *offset, int *nb, int *kb, double *a, int *lda, int *jpvt, double *tau, double *vn1, double *vn2, double *auxv, double *f, int *ldf) { /* System generated locals */ int a_dim1, a_offset, f_dim1, f_offset, i__1, i__2; double d__1, d__2; /* Builtin functions */ double sqrt(double); int i_dnnt(double *); /* Local variables */ int j, k, rk; double akk; int pvt; double temp; extern double dnrm2_(int *, double *, int *); double temp2, tol3z; extern int dgemm_(char *, char *, int *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *), dgemv_(char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *); int itemp; extern int dswap_(int *, double *, int *, double *, int *); extern double dlamch_(char *); extern int idamax_(int *, double *, int *); extern int dlarfp_(int *, double *, double *, int *, double *); int lsticc, lastrk; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DLAQPS computes a step of QR factorization with column pivoting */ /* of a float 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (KB) */ /* The scalar factors of the elementary reflectors. */ /* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */ /* The vector with the partial column norms. */ /* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */ /* The vector with the exact column norms. */ /* AUXV (input/output) DOUBLE PRECISION array, dimension (NB) */ /* Auxiliar vector. */ /* F (input/output) DOUBLE PRECISION 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. */ /* ===================================================================== */ /* .. 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; --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(dlamch_("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 + idamax_(&i__1, &vn1[k], &c__1); if (pvt != k) { dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); i__1 = k - 1; dswap_(&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 = *m - rk + 1; i__2 = k - 1; dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[rk + a_dim1], lda, &f[k + f_dim1], ldf, &c_b9, &a[rk + k * a_dim1], &c__1); } /* Generate elementary reflector H(k). */ if (rk < *m) { i__1 = *m - rk + 1; dlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], & c__1, &tau[k]); } else { dlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, & tau[k]); } akk = a[rk + k * a_dim1]; a[rk + k * a_dim1] = 1.; /* 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; dgemv_("Transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b16, &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) { f[j + k * f_dim1] = 0.; /* L20: */ } /* 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; d__1 = -tau[k]; dgemv_("Transpose", &i__1, &i__2, &d__1, &a[rk + a_dim1], lda, &a[ rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1); i__1 = k - 1; dgemv_("No transpose", n, &i__1, &c_b9, &f[f_dim1 + 1], ldf, & auxv[1], &c__1, &c_b9, &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; dgemv_("No transpose", &i__1, &k, &c_b8, &f[k + 1 + f_dim1], ldf, &a[rk + a_dim1], lda, &c_b9, &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.) { /* NOTE: The following 4 lines follow from the analysis in */ /* Lapack Working Note 176. */ temp = (d__1 = a[rk + j * a_dim1], ABS(d__1)) / vn1[j]; /* Computing MAX */ d__1 = 0., d__2 = (temp + 1.) * (1. - temp); temp = MAX(d__1,d__2); /* Computing 2nd power */ d__1 = vn1[j] / vn2[j]; temp2 = temp * (d__1 * d__1); if (temp2 <= tol3z) { vn2[j] = (double) lsticc; lsticc = j; } else { vn1[j] *= sqrt(temp); } } /* L30: */ } } a[rk + k * a_dim1] = akk; /* 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; dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b8, &a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b9, &a[rk + 1 + (*kb + 1) * a_dim1], lda); } /* Recomputation of difficult columns. */ L40: if (lsticc > 0) { itemp = i_dnnt(&vn2[lsticc]); i__1 = *m - rk; vn1[lsticc] = dnrm2_(&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 L40; } return 0; /* End of DLAQPS */ } /* dlaqps_ */