int zggglm_(int *n, int *m, int *p, doublecomplex *a, int *lda, doublecomplex *b, int *ldb, doublecomplex *d__, doublecomplex *x, doublecomplex *y, doublecomplex *work, int *lwork, int *info) { /* System generated locals */ int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; doublecomplex z__1; /* Local variables */ int i__, nb, np, nb1, nb2, nb3, nb4, lopt; extern int zgemv_(char *, int *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *), zcopy_(int *, doublecomplex *, int *, doublecomplex *, int *), xerbla_(char *, int *); extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); extern int zggqrf_(int *, int *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, int *) ; int lwkmin, lwkopt; int lquery; extern int zunmqr_(char *, char *, int *, int *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, int *), zunmrq_(char *, char *, int *, int *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, int *), ztrtrs_(char *, char *, char *, int *, int *, doublecomplex *, int *, doublecomplex *, int *, int *); /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGGGLM solves a general Gauss-Markov linear model (GLM) problem: */ /* minimize || y ||_2 subject to d = A*x + B*y */ /* x */ /* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */ /* given N-vector. It is assumed that M <= N <= M+P, and */ /* rank(A) = M and rank( A B ) = N. */ /* Under these assumptions, the constrained equation is always */ /* consistent, and there is a unique solution x and a minimal 2-norm */ /* solution y, which is obtained using a generalized QR factorization */ /* of the matrices (A, B) given by */ /* A = Q*(R), B = Q*T*Z. */ /* (0) */ /* In particular, if matrix B is square nonsingular, then the problem */ /* GLM is equivalent to the following weighted linear least squares */ /* problem */ /* minimize || inv(B)*(d-A*x) ||_2 */ /* x */ /* where inv(B) denotes the inverse of B. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of rows of the matrices A and B. N >= 0. */ /* M (input) INTEGER */ /* The number of columns of the matrix A. 0 <= M <= N. */ /* P (input) INTEGER */ /* The number of columns of the matrix B. P >= N-M. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,M) */ /* On entry, the N-by-M matrix A. */ /* On exit, the upper triangular part of the array A contains */ /* the M-by-M upper triangular matrix R. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= MAX(1,N). */ /* B (input/output) COMPLEX*16 array, dimension (LDB,P) */ /* On entry, the N-by-P matrix B. */ /* On exit, if N <= P, the upper triangle of the subarray */ /* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ /* if N > P, the elements on and above the (N-P)th subdiagonal */ /* contain the N-by-P upper trapezoidal matrix T. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= MAX(1,N). */ /* D (input/output) COMPLEX*16 array, dimension (N) */ /* On entry, D is the left hand side of the GLM equation. */ /* On exit, D is destroyed. */ /* X (output) COMPLEX*16 array, dimension (M) */ /* Y (output) COMPLEX*16 array, dimension (P) */ /* On exit, X and Y are the solutions of the GLM problem. */ /* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= MAX(1,N+M+P). */ /* For optimum performance, LWORK >= M+MIN(N,P)+MAX(N,P)*NB, */ /* where NB is an upper bound for the optimal blocksizes for */ /* ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* = 1: the upper triangular factor R associated with A in the */ /* generalized QR factorization of the pair (A, B) is */ /* singular, so that rank(A) < M; the least squares */ /* solution could not be computed. */ /* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */ /* factor T associated with B in the generalized QR */ /* factorization of the pair (A, B) is singular, so that */ /* rank( A B ) < N; the least squares solution could not */ /* be computed. */ /* =================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --d__; --x; --y; --work; /* Function Body */ *info = 0; np = MIN(*n,*p); lquery = *lwork == -1; if (*n < 0) { *info = -1; } else if (*m < 0 || *m > *n) { *info = -2; } else if (*p < 0 || *p < *n - *m) { *info = -3; } else if (*lda < MAX(1,*n)) { *info = -5; } else if (*ldb < MAX(1,*n)) { *info = -7; } /* Calculate workspace */ if (*info == 0) { if (*n == 0) { lwkmin = 1; lwkopt = 1; } else { nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, m, &c_n1, &c_n1); nb2 = ilaenv_(&c__1, "ZGERQF", " ", n, m, &c_n1, &c_n1); nb3 = ilaenv_(&c__1, "ZUNMQR", " ", n, m, p, &c_n1); nb4 = ilaenv_(&c__1, "ZUNMRQ", " ", n, m, p, &c_n1); /* Computing MAX */ i__1 = MAX(nb1,nb2), i__1 = MAX(i__1,nb3); nb = MAX(i__1,nb4); lwkmin = *m + *n + *p; lwkopt = *m + np + MAX(*n,*p) * nb; } work[1].r = (double) lwkopt, work[1].i = 0.; if (*lwork < lwkmin && ! lquery) { *info = -12; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZGGGLM", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Compute the GQR factorization of matrices A and B: */ /* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */ /* ( 0 ) N-M ( 0 T22 ) N-M */ /* M M+P-N N-M */ /* where R11 and T22 are upper triangular, and Q and Z are */ /* unitary. */ i__1 = *lwork - *m - np; zggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m + 1], &work[*m + np + 1], &i__1, info); i__1 = *m + np + 1; lopt = (int) work[i__1].r; /* Update left-hand-side vector d = Q'*d = ( d1 ) M */ /* ( d2 ) N-M */ i__1 = MAX(1,*n); i__2 = *lwork - *m - np; zunmqr_("Left", "Conjugate transpose", n, &c__1, m, &a[a_offset], lda, & work[1], &d__[1], &i__1, &work[*m + np + 1], &i__2, info); /* Computing MAX */ i__3 = *m + np + 1; i__1 = lopt, i__2 = (int) work[i__3].r; lopt = MAX(i__1,i__2); /* Solve T22*y2 = d2 for y2 */ if (*n > *m) { i__1 = *n - *m; i__2 = *n - *m; ztrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1 + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2, info); if (*info > 0) { *info = 1; return 0; } i__1 = *n - *m; zcopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1); } /* Set y1 = 0 */ i__1 = *m + *p - *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; y[i__2].r = 0., y[i__2].i = 0.; /* L10: */ } /* Update d1 = d1 - T12*y2 */ i__1 = *n - *m; z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", m, &i__1, &z__1, &b[(*m + *p - *n + 1) * b_dim1 + 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b2, &d__[1], &c__1); /* Solve triangular system: R11*x = d1 */ if (*m > 0) { ztrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset], lda, &d__[1], m, info); if (*info > 0) { *info = 2; return 0; } /* Copy D to X */ zcopy_(m, &d__[1], &c__1, &x[1], &c__1); } /* Backward transformation y = Z'*y */ /* Computing MAX */ i__1 = 1, i__2 = *n - *p + 1; i__3 = MAX(1,*p); i__4 = *lwork - *m - np; zunmrq_("Left", "Conjugate transpose", p, &c__1, &np, &b[MAX(i__1, i__2)+ b_dim1], ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], & i__4, info); /* Computing MAX */ i__4 = *m + np + 1; i__2 = lopt, i__3 = (int) work[i__4].r; i__1 = *m + np + MAX(i__2,i__3); work[1].r = (double) i__1, work[1].i = 0.; return 0; /* End of ZGGGLM */ } /* zggglm_ */
/* Subroutine */ int zggglm_(integer *n, integer *m, integer *p, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *d, doublecomplex *x, doublecomplex *y, doublecomplex * work, integer *lwork, integer *info) { /* -- LAPACK driver routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZGGGLM solves a general Gauss-Markov linear model (GLM) problem: minimize || y ||_2 subject to d = A*x + B*y x where A is an N-by-M matrix, B is an N-by-P matrix, and d is a given N-vector. It is assumed that M <= N <= M+P, and rank(A) = M and rank( A B ) = N. Under these assumptions, the constrained equation is always consistent, and there is a unique solution x and a minimal 2-norm solution y, which is obtained using a generalized QR factorization of A and B. In particular, if matrix B is square nonsingular, then the problem GLM is equivalent to the following weighted linear least squares problem minimize || inv(B)*(d-A*x) ||_2 x where inv(B) denotes the inverse of B. Arguments ========= N (input) INTEGER The number of rows of the matrices A and B. N >= 0. M (input) INTEGER The number of columns of the matrix A. 0 <= M <= N. P (input) INTEGER The number of columns of the matrix B. P >= N-M. A (input/output) COMPLEX*16 array, dimension (LDA,M) On entry, the N-by-M matrix A. On exit, A is destroyed. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input/output) COMPLEX*16 array, dimension (LDB,P) On entry, the N-by-P matrix B. On exit, B is destroyed. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). D (input/output) COMPLEX*16 array, dimension (N) On entry, D is the left hand side of the GLM equation. On exit, D is destroyed. X (output) COMPLEX*16 array, dimension (M) Y (output) COMPLEX*16 array, dimension (P) On exit, X and Y are the solutions of the GLM problem. WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= max(1,N+M+P). For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, where NB is an upper bound for the optimal blocksizes for ZGEQRF, CGERQF, ZUNMQR and CUNMRQ. INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. =================================================================== Test the input parameters Parameter adjustments Function Body */ /* Table of constant values */ static doublecomplex c_b2 = {1.,0.}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; doublereal d__1; doublecomplex z__1; /* Local variables */ static integer lopt, i; extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztrsv_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer np; extern /* Subroutine */ int xerbla_(char *, integer *), zggqrf_( integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmrq_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); #define D(I) d[(I)-1] #define X(I) x[(I)-1] #define Y(I) y[(I)-1] #define WORK(I) work[(I)-1] #define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)] #define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)] *info = 0; np = min(*n,*p); if (*n < 0) { *info = -1; } else if (*m < 0 || *m > *n) { *info = -2; } else if (*p < 0 || *p < *n - *m) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = 1, i__2 = *n + *m + *p; if (*lwork < max(i__1,i__2)) { *info = -12; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZGGGLM", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Compute the GQR factorization of matrices A and B: Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M ( 0 ) N-M ( 0 T22 ) N-M M M+P-N N-M where R11 and T22 are upper triangular, and Q and Z are unitary. */ i__1 = *lwork - *m - np; zggqrf_(n, m, p, &A(1,1), lda, &WORK(1), &B(1,1), ldb, &WORK(*m + 1), &WORK(*m + np + 1), &i__1, info); i__1 = *m + np + 1; lopt = (integer) WORK(*m+np+1).r; /* Update left-hand-side vector d = Q'*d = ( d1 ) M ( d2 ) N-M */ i__1 = max(1,*n); i__2 = *lwork - *m - np; zunmqr_("Left", "Conjugate transpose", n, &c__1, m, &A(1,1), lda, & WORK(1), &D(1), &i__1, &WORK(*m + np + 1), &i__2, info); /* Computing MAX */ i__3 = *m + np + 1; i__1 = lopt, i__2 = (integer) WORK(*m+np+1).r; lopt = max(i__1,i__2); /* Solve T22*y2 = d2 for y2 */ i__1 = *n - *m; ztrsv_("Upper", "No transpose", "Non unit", &i__1, &B(*m+1,*m+*p-*n+1), ldb, &D(*m + 1), &c__1); i__1 = *n - *m; zcopy_(&i__1, &D(*m + 1), &c__1, &Y(*m + *p - *n + 1), &c__1); /* Set y1 = 0 */ i__1 = *m + *p - *n; for (i = 1; i <= *m+*p-*n; ++i) { i__2 = i; Y(i).r = 0., Y(i).i = 0.; /* L10: */ } /* Update d1 = d1 - T12*y2 */ i__1 = *n - *m; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", m, &i__1, &z__1, &B(1,*m+*p-*n+1), ldb, &Y(*m + *p - *n + 1), &c__1, &c_b2, &D(1), &c__1); /* Solve triangular system: R11*x = d1 */ ztrsv_("Upper", "No Transpose", "Non unit", m, &A(1,1), lda, &D(1), & c__1); /* Copy D to X */ zcopy_(m, &D(1), &c__1, &X(1), &c__1); /* Backward transformation y = Z'*y Computing MAX */ i__1 = 1, i__2 = *n - *p + 1; i__3 = max(1,*p); i__4 = *lwork - *m - np; zunmrq_("Left", "Conjugate transpose", p, &c__1, &np, &B(max(1,*n-*p+1),1), ldb, &WORK(*m + 1), &Y(1), &i__3, &WORK(*m + np + 1), & i__4, info); /* Computing MAX */ i__3 = *m + np + 1; i__1 = lopt, i__2 = (integer) WORK(*m+np+1).r; d__1 = (doublereal) max(i__1,i__2); WORK(1).r = d__1, WORK(1).i = 0.; return 0; /* End of ZGGGLM */ } /* zggglm_ */
/* Subroutine */ int zgqrts_(integer *n, integer *m, integer *p, doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex * r__, integer *lda, doublecomplex *taua, doublecomplex *b, doublecomplex *bf, doublecomplex *z__, doublecomplex *t, doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex * work, integer *lwork, doublereal *rwork, doublereal *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1, bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1, r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2; doublereal d__1; doublecomplex z__1; /* Local variables */ doublereal ulp; integer info; doublereal unfl, resid, anorm, bnorm; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zherk_(char *, char *, integer *, integer *, doublereal *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *); extern doublereal dlamch_(char *), zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *), zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *); extern /* Subroutine */ int zggqrf_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *) , zlacpy_(char *, integer *, integer *, doublecomplex *, integer * , doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zungqr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zungrq_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGQRTS tests ZGGQRF, which computes the GQR factorization of an */ /* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of rows of the matrices A and B. N >= 0. */ /* M (input) INTEGER */ /* The number of columns of the matrix A. M >= 0. */ /* P (input) INTEGER */ /* The number of columns of the matrix B. P >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,M) */ /* The N-by-M matrix A. */ /* AF (output) COMPLEX*16 array, dimension (LDA,N) */ /* Details of the GQR factorization of A and B, as returned */ /* by ZGGQRF, see CGGQRF for further details. */ /* Q (output) COMPLEX*16 array, dimension (LDA,N) */ /* The M-by-M unitary matrix Q. */ /* R (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N)) */ /* LDA (input) INTEGER */ /* The leading dimension of the arrays A, AF, R and Q. */ /* LDA >= max(M,N). */ /* TAUA (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors, as returned */ /* by ZGGQRF. */ /* B (input) COMPLEX*16 array, dimension (LDB,P) */ /* On entry, the N-by-P matrix A. */ /* BF (output) COMPLEX*16 array, dimension (LDB,N) */ /* Details of the GQR factorization of A and B, as returned */ /* by ZGGQRF, see CGGQRF for further details. */ /* Z (output) COMPLEX*16 array, dimension (LDB,P) */ /* The P-by-P unitary matrix Z. */ /* T (workspace) COMPLEX*16 array, dimension (LDB,max(P,N)) */ /* BWK (workspace) COMPLEX*16 array, dimension (LDB,N) */ /* LDB (input) INTEGER */ /* The leading dimension of the arrays B, BF, Z and T. */ /* LDB >= max(P,N). */ /* TAUB (output) COMPLEX*16 array, dimension (min(P,N)) */ /* The scalar factors of the elementary reflectors, as returned */ /* by DGGRQF. */ /* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK, LWORK >= max(N,M,P)**2. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (max(N,M,P)) */ /* RESULT (output) DOUBLE PRECISION array, dimension (4) */ /* The test ratios: */ /* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) */ /* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) */ /* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) */ /* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ r_dim1 = *lda; r_offset = 1 + r_dim1; r__ -= r_offset; q_dim1 = *lda; q_offset = 1 + q_dim1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --taua; bwk_dim1 = *ldb; bwk_offset = 1 + bwk_dim1; bwk -= bwk_offset; t_dim1 = *ldb; t_offset = 1 + t_dim1; t -= t_offset; z_dim1 = *ldb; z_offset = 1 + z_dim1; z__ -= z_offset; bf_dim1 = *ldb; bf_offset = 1 + bf_dim1; bf -= bf_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --taub; --work; --rwork; --result; /* Function Body */ ulp = dlamch_("Precision"); unfl = dlamch_("Safe minimum"); /* Copy the matrix A to the array AF. */ zlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda); zlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb); /* Computing MAX */ d__1 = zlange_("1", n, m, &a[a_offset], lda, &rwork[1]); anorm = max(d__1,unfl); /* Computing MAX */ d__1 = zlange_("1", n, p, &b[b_offset], ldb, &rwork[1]); bnorm = max(d__1,unfl); /* Factorize the matrices A and B in the arrays AF and BF. */ zggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, & taub[1], &work[1], lwork, &info); /* Generate the N-by-N matrix Q */ zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda); i__1 = *n - 1; zlacpy_("Lower", &i__1, m, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda); i__1 = min(*n,*m); zungqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info); /* Generate the P-by-P matrix Z */ zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb); if (*n <= *p) { if (*n > 0 && *n < *p) { i__1 = *p - *n; zlacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z__[*p - *n + 1 + z_dim1], ldb); } if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; zlacpy_("Lower", &i__1, &i__2, &bf[(*p - *n + 1) * bf_dim1 + 2], ldb, &z__[*p - *n + 2 + (*p - *n + 1) * z_dim1], ldb); } } else { if (*p > 1) { i__1 = *p - 1; i__2 = *p - 1; zlacpy_("Lower", &i__1, &i__2, &bf[*n - *p + 2 + bf_dim1], ldb, & z__[z_dim1 + 2], ldb); } } i__1 = min(*n,*p); zungrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, & info); /* Copy R */ zlaset_("Full", n, m, &c_b1, &c_b1, &r__[r_offset], lda); zlacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda); /* Copy T */ zlaset_("Full", n, p, &c_b1, &c_b1, &t[t_offset], ldb); if (*n <= *p) { zlacpy_("Upper", n, n, &bf[(*p - *n + 1) * bf_dim1 + 1], ldb, &t[(*p - *n + 1) * t_dim1 + 1], ldb); } else { i__1 = *n - *p; zlacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb); zlacpy_("Upper", p, p, &bf[*n - *p + 1 + bf_dim1], ldb, &t[*n - *p + 1 + t_dim1], ldb); } /* Compute R - Q'*A */ z__1.r = -1., z__1.i = -0.; zgemm_("Conjugate transpose", "No transpose", n, m, n, &z__1, &q[q_offset] , lda, &a[a_offset], lda, &c_b2, &r__[r_offset], lda); /* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */ resid = zlange_("1", n, m, &r__[r_offset], lda, &rwork[1]); if (anorm > 0.) { /* Computing MAX */ i__1 = max(1,*m); result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp; } else { result[1] = 0.; } /* Compute T*Z - Q'*B */ zgemm_("No Transpose", "No transpose", n, p, p, &c_b2, &t[t_offset], ldb, &z__[z_offset], ldb, &c_b1, &bwk[bwk_offset], ldb); z__1.r = -1., z__1.i = -0.; zgemm_("Conjugate transpose", "No transpose", n, p, n, &z__1, &q[q_offset] , lda, &b[b_offset], ldb, &c_b2, &bwk[bwk_offset], ldb); /* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */ resid = zlange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]); if (bnorm > 0.) { /* Computing MAX */ i__1 = max(1,*p); result[2] = resid / (doublereal) max(i__1,*n) / bnorm / ulp; } else { result[2] = 0.; } /* Compute I - Q'*Q */ zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda); zherk_("Upper", "Conjugate transpose", n, n, &c_b34, &q[q_offset], lda, & c_b35, &r__[r_offset], lda); /* Compute norm( I - Q'*Q ) / ( N * ULP ) . */ resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]); result[3] = resid / (doublereal) max(1,*n) / ulp; /* Compute I - Z'*Z */ zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb); zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb, &c_b35, &t[t_offset], ldb); /* Compute norm( I - Z'*Z ) / ( P*ULP ) . */ resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]); result[4] = resid / (doublereal) max(1,*p) / ulp; return 0; /* End of ZGQRTS */ } /* zgqrts_ */