/* Subroutine */ int sgeqr2_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__, k; real aii; extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), xerbla_( char *, integer *), slarfp_(integer *, real *, real *, integer *, real *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SGEQR2 computes a QR factorization of a real m by n matrix A: */ /* A = Q * R. */ /* 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) REAL array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, the elements on and above the diagonal of the array */ /* contain the min(m,n) by n upper trapezoidal matrix R (R is */ /* upper triangular if m >= n); the elements below the diagonal, */ /* 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) REAL array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) REAL 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(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 real scalar, and v is a real vector with */ /* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,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_("SGEQR2", &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+1:m,i) */ i__2 = *m - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; slarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1] , &c__1, &tau[i__]); if (i__ < *n) { /* Apply H(i) to A(i:m,i+1:n) from the left */ aii = a[i__ + i__ * a_dim1]; a[i__ + i__ * a_dim1] = 1.f; i__2 = *m - i__ + 1; i__3 = *n - i__; slarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); a[i__ + i__ * a_dim1] = aii; } /* L10: */ } return 0; /* End of SGEQR2 */ } /* sgeqr2_ */
int slaqps_(int *m, int *n, int *offset, int *nb, int *kb, float *a, int *lda, int *jpvt, float *tau, float *vn1, float *vn2, float *auxv, float *f, int *ldf) { /* System generated locals */ int a_dim1, a_offset, f_dim1, f_offset, i__1, i__2; float r__1, r__2; /* Builtin functions */ double sqrt(double); int i_nint(float *); /* Local variables */ int j, k, rk; float akk; int pvt; float temp, temp2; extern double snrm2_(int *, float *, int *); float tol3z; extern int sgemm_(char *, char *, int *, int *, int *, float *, float *, int *, float *, int *, float *, float *, int *); int itemp; extern int sgemv_(char *, int *, int *, float *, float *, int *, float *, int *, float *, float *, int *), sswap_(int *, float *, int *, float *, int *); extern double slamch_(char *); int lsticc; extern int isamax_(int *, float *, int *); extern int slarfp_(int *, float *, float *, int *, float *); int lastrk; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLAQPS 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) REAL 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) REAL 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) REAL array, dimension (NB) */ /* Auxiliar vector. */ /* F (input/output) REAL 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(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) { sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); i__1 = k - 1; sswap_(&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; sgemv_("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; slarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], & c__1, &tau[k]); } else { slarfp_(&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.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; sgemv_("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.f; /* 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; r__1 = -tau[k]; sgemv_("Transpose", &i__1, &i__2, &r__1, &a[rk + a_dim1], lda, &a[ rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1); i__1 = k - 1; sgemv_("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; sgemv_("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.f) { /* NOTE: The following 4 lines follow from the analysis in */ /* Lapack Working Note 176. */ temp = (r__1 = a[rk + j * a_dim1], ABS(r__1)) / vn1[j]; /* Computing MAX */ r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp); temp = MAX(r__1,r__2); /* Computing 2nd power */ r__1 = vn1[j] / vn2[j]; temp2 = temp * (r__1 * r__1); if (temp2 <= tol3z) { vn2[j] = (float) 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; sgemm_("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_nint(&vn2[lsticc]); i__1 = *m - rk; vn1[lsticc] = snrm2_(&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 SLAQPS */ } /* slaqps_ */
int stzrqf_(int *m, int *n, float *a, int *lda, float *tau, int *info) { /* System generated locals */ int a_dim1, a_offset, i__1, i__2; float r__1; /* Local variables */ int i__, k, m1; extern int sger_(int *, int *, float *, float *, int *, float *, int *, float *, int *), sgemv_(char *, int *, int *, float *, float *, int *, float *, int * , float *, float *, int *), scopy_(int *, float *, int *, float *, int *), saxpy_(int *, float *, float *, int *, float *, int *), xerbla_(char *, int *), slarfp_(int *, float *, float *, int *, float *); /* -- 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 STZRZF. */ /* STZRQF 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) REAL 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) REAL 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_("STZRQF", &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.f; /* 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; slarfp_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[ k]); if (tau[k] != 0.f && 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; scopy_(&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; sgemv_("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; r__1 = -tau[k]; saxpy_(&i__1, &r__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & c__1); i__1 = k - 1; i__2 = *n - *m; r__1 = -tau[k]; sger_(&i__1, &i__2, &r__1, &tau[1], &c__1, &a[k + m1 * a_dim1] , lda, &a[m1 * a_dim1 + 1], lda); } /* L20: */ } } return 0; /* End of STZRQF */ } /* stzrqf_ */
int slaqp2_(int *m, int *n, int *offset, float *a, int *lda, int *jpvt, float *tau, float *vn1, float *vn2, float * work) { /* System generated locals */ int a_dim1, a_offset, i__1, i__2, i__3; float r__1, r__2; /* Builtin functions */ double sqrt(double); /* Local variables */ int i__, j, mn; float aii; int pvt; float temp, temp2; extern double snrm2_(int *, float *, int *); float tol3z; int offpi; extern int slarf_(char *, int *, int *, float *, int *, float *, float *, int *, float *); int itemp; extern int sswap_(int *, float *, int *, float *, int *); extern double slamch_(char *); extern int isamax_(int *, float *, int *); extern int slarfp_(int *, float *, float *, int *, float *); /* -- 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 */ /* ======= */ /* SLAQP2 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) REAL 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) REAL 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) REAL 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__) { sswap_(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; slarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ * a_dim1], &c__1, &tau[i__]); } else { slarfp_(&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. */ aii = a[offpi + i__ * a_dim1]; a[offpi + i__ * a_dim1] = 1.f; i__2 = *m - offpi + 1; i__3 = *n - i__; slarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, & tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]); a[offpi + i__ * a_dim1] = aii; } /* 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__2 = (r__1 = a[offpi + j * a_dim1], ABS(r__1)) / vn1[j]; temp = 1.f - r__2 * r__2; temp = MAX(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] = snrm2_(&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 SLAQP2 */ } /* slaqp2_ */
/* Subroutine */ int sgerq2_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; /* Local variables */ integer i__, k; real aii; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SGERQ2 computes an RQ factorization of a real 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) REAL 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 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) REAL array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) REAL 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 real scalar, and v is a real vector with */ /* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; 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_("SGERQ2", &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__; slarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &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 */ aii = a[*m - k + i__ + (*n - k + i__) * a_dim1]; a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.f; i__1 = *m - k + i__ - 1; i__2 = *n - k + i__; slarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[ i__], &a[a_offset], lda, &work[1]); a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii; } return 0; /* End of SGERQ2 */ } /* sgerq2_ */
/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda, integer *jpvt, real *tau, real *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, ma, mn; real aii; integer pvt; real temp, temp2; extern doublereal snrm2_(integer *, real *, integer *); real tol3z; extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *); integer itemp; extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, integer *), sgeqr2_(integer *, integer *, real *, integer *, real *, real *, integer *), sorm2r_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real * , integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); extern integer isamax_(integer *, real *, integer *); extern /* Subroutine */ int slarfp_(integer *, real *, real *, integer *, real *); /* -- LAPACK deprecated driver 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 SGEQP3. */ /* SGEQPF computes a QR factorization with column pivoting of a */ /* real M-by-N matrix A: A*P = Q*R. */ /* 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) REAL array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, the upper triangle of the array contains the */ /* min(M,N)-by-N upper triangular matrix R; the elements */ /* below the diagonal, together with the array TAU, */ /* represent the orthogonal matrix Q as a product of */ /* min(m,n) elementary reflectors. */ /* 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) REAL array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors. */ /* WORK (workspace) REAL array, dimension (3*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(1) H(2) . . . H(n) */ /* Each H(i) has the form */ /* H = I - tau * v * v' */ /* where tau is a real scalar, and v is a real vector with */ /* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */ /* The matrix P is represented in jpvt as follows: If */ /* jpvt(j) = i */ /* then the jth column of P is the ith canonical unit vector. */ /* 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 .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --jpvt; --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_("SGEQPF", &i__1); return 0; } mn = min(*m,*n); tol3z = sqrt(slamch_("Epsilon")); /* Move initial columns up front */ itemp = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (jpvt[i__] != 0) { if (i__ != itemp) { sswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1], &c__1); jpvt[i__] = jpvt[itemp]; jpvt[itemp] = i__; } else { jpvt[i__] = i__; } ++itemp; } else { jpvt[i__] = i__; } /* L10: */ } --itemp; /* Compute the QR factorization and update remaining columns */ if (itemp > 0) { ma = min(itemp,*m); sgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info); if (ma < *n) { i__1 = *n - ma; sorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, & tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info); } } if (itemp < mn) { /* Initialize partial column norms. The first n elements of */ /* work store the exact column norms. */ i__1 = *n; for (i__ = itemp + 1; i__ <= i__1; ++i__) { i__2 = *m - itemp; work[i__] = snrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1); work[*n + i__] = work[i__]; /* L20: */ } /* Compute factorization */ i__1 = mn; for (i__ = itemp + 1; i__ <= i__1; ++i__) { /* Determine ith pivot column and swap if necessary */ i__2 = *n - i__ + 1; pvt = i__ - 1 + isamax_(&i__2, &work[i__], &c__1); if (pvt != i__) { sswap_(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; work[pvt] = work[i__]; work[*n + pvt] = work[*n + i__]; } /* Generate elementary reflector H(i) */ if (i__ < *m) { i__2 = *m - i__ + 1; slarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__]); } else { slarfp_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], & c__1, &tau[*m]); } if (i__ < *n) { /* Apply H(i) to A(i:m,i+1:n) from the left */ aii = a[i__ + i__ * a_dim1]; a[i__ + i__ * a_dim1] = 1.f; i__2 = *m - i__ + 1; i__3 = *n - i__; slarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(* n << 1) + 1]); a[i__ + i__ * a_dim1] = aii; } /* Update partial column norms */ i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { if (work[j] != 0.f) { /* NOTE: The following 4 lines follow from the analysis in */ /* Lapack Working Note 176. */ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1)) / work[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 = work[j] / work[*n + j]; temp2 = temp * (r__1 * r__1); if (temp2 <= tol3z) { if (*m - i__ > 0) { i__3 = *m - i__; work[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1], &c__1); work[*n + j] = work[j]; } else { work[j] = 0.f; work[*n + j] = 0.f; } } else { work[j] *= sqrt(temp); } } /* L30: */ } /* L40: */ } } return 0; /* End of SGEQPF */ } /* sgeqpf_ */