/* Subroutine */ int zrqt02_(integer *m, integer *n, integer *k, doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex * r__, integer *lda, doublecomplex *tau, doublecomplex *work, integer * lwork, doublereal *rwork, doublereal *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1, r_offset, i__1, i__2; /* Local variables */ doublereal eps; integer info; doublereal resid, anorm; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZRQT02 tests ZUNGRQ, which generates an m-by-n matrix Q with */ /* orthonornmal rows that is defined as the product of k elementary */ /* reflectors. */ /* Given the RQ factorization of an m-by-n matrix A, ZRQT02 generates */ /* the orthogonal matrix Q defined by the factorization of the last k */ /* rows of A; it compares R(m-k+1:m,n-m+1:n) with */ /* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */ /* orthonormal. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix Q to be generated. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix Q to be generated. */ /* N >= M >= 0. */ /* K (input) INTEGER */ /* The number of elementary reflectors whose product defines the */ /* matrix Q. M >= K >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The m-by-n matrix A which was factorized by ZRQT01. */ /* AF (input) COMPLEX*16 array, dimension (LDA,N) */ /* Details of the RQ factorization of A, as returned by ZGERQF. */ /* See ZGERQF for further details. */ /* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */ /* R (workspace) COMPLEX*16 array, dimension (LDA,M) */ /* LDA (input) INTEGER */ /* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */ /* TAU (input) COMPLEX*16 array, dimension (M) */ /* The scalar factors of the elementary reflectors corresponding */ /* to the RQ factorization in AF. */ /* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */ /* RESULT (output) DOUBLE PRECISION array, dimension (2) */ /* The test ratios: */ /* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */ /* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Executable Statements .. */ /* Quick return if possible */ /* 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; --tau; --work; --rwork; --result; /* Function Body */ if (*m == 0 || *n == 0 || *k == 0) { result[1] = 0.; result[2] = 0.; return 0; } eps = dlamch_("Epsilon"); /* Copy the last k rows of the factorization to the array Q */ zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda); if (*k < *n) { i__1 = *n - *k; zlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k + 1 + q_dim1], lda); } if (*k > 1) { i__1 = *k - 1; i__2 = *k - 1; zlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) * af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda); } /* Generate the last n rows of the matrix Q */ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)32, (ftnlen)6); zungrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, & info); /* Copy R(m-k+1:m,n-m+1:n) */ zlaset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1], lda); zlacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, & r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda); /* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */ zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k + 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1], lda); /* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */ anorm = zlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]); resid = zlange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1], lda, &rwork[1]); if (anorm > 0.) { result[1] = resid / (doublereal) max(1,*n) / anorm / eps; } else { result[1] = 0.; } /* Compute I - Q*Q' */ zlaset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda); zherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, & r__[r_offset], lda); /* Compute norm( I - Q*Q' ) / ( N * EPS ) . */ resid = zlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]); result[2] = resid / (doublereal) max(1,*n) / eps; return 0; /* End of ZRQT02 */ } /* zrqt02_ */
/* Subroutine */ int zgrqts_(integer *m, integer *p, integer *n, 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 */ static integer info; static 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 zggrqf_(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 *); static doublereal ulp; #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1 #define r___ref(a_1,a_2) r__[r___subscr(a_1,a_2)] #define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1 #define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1 #define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)] #define bf_subscr(a_1,a_2) (a_2)*bf_dim1 + a_1 #define bf_ref(a_1,a_2) bf[bf_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZGRQTS tests ZGGRQF, which computes the GRQ factorization of an M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q. Arguments ========= M (input) INTEGER The number of rows of the matrix A. M >= 0. P (input) INTEGER The number of rows of the matrix B. P >= 0. N (input) INTEGER The number of columns of the matrices A and B. N >= 0. A (input) COMPLEX*16 array, dimension (LDA,N) The M-by-N matrix A. AF (output) COMPLEX*16 array, dimension (LDA,N) Details of the GRQ factorization of A and B, as returned by ZGGRQF, see CGGRQF for further details. Q (output) COMPLEX*16 array, dimension (LDA,N) The N-by-N 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 DGGQRC. B (input) COMPLEX*16 array, dimension (LDB,N) On entry, the P-by-N matrix A. BF (output) COMPLEX*16 array, dimension (LDB,N) Details of the GQR factorization of A and B, as returned by ZGGRQF, see CGGRQF for further details. Z (output) DOUBLE PRECISION 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(M,P,N)**2. RWORK (workspace) DOUBLE PRECISION array, dimension (M) RESULT (output) DOUBLE PRECISION array, dimension (4) The test ratios: RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP) RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP) RESULT(3) = norm( I - Q'*Q ) / ( N*ULP ) RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) ===================================================================== Parameter adjustments */ r_dim1 = *lda; r_offset = 1 + r_dim1 * 1; r__ -= r_offset; q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --taua; bwk_dim1 = *ldb; bwk_offset = 1 + bwk_dim1 * 1; bwk -= bwk_offset; t_dim1 = *ldb; t_offset = 1 + t_dim1 * 1; t -= t_offset; z_dim1 = *ldb; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; bf_dim1 = *ldb; bf_offset = 1 + bf_dim1 * 1; bf -= bf_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; 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", m, n, &a[a_offset], lda, &af[af_offset], lda); zlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb); /* Computing MAX */ d__1 = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]); anorm = max(d__1,unfl); /* Computing MAX */ d__1 = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]); bnorm = max(d__1,unfl); /* Factorize the matrices A and B in the arrays AF and BF. */ zggrqf_(m, p, n, &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); if (*m <= *n) { if (*m > 0 && *m < *n) { i__1 = *n - *m; zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q_ref(*n - *m + 1, 1), lda); } if (*m > 1) { i__1 = *m - 1; i__2 = *m - 1; zlacpy_("Lower", &i__1, &i__2, &af_ref(2, *n - *m + 1), lda, & q_ref(*n - *m + 2, *n - *m + 1), lda); } } else { if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; zlacpy_("Lower", &i__1, &i__2, &af_ref(*m - *n + 2, 1), lda, & q_ref(2, 1), lda); } } i__1 = min(*m,*n); zungrq_(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 (*p > 1) { i__1 = *p - 1; zlacpy_("Lower", &i__1, n, &bf_ref(2, 1), ldb, &z___ref(2, 1), ldb); } i__1 = min(*p,*n); zungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, & info); /* Copy R */ zlaset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda); if (*m <= *n) { zlacpy_("Upper", m, m, &af_ref(1, *n - *m + 1), lda, &r___ref(1, *n - *m + 1), lda); } else { i__1 = *m - *n; zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda); zlacpy_("Upper", n, n, &af_ref(*m - *n + 1, 1), lda, &r___ref(*m - *n + 1, 1), lda); } /* Copy T */ zlaset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb); zlacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb); /* Compute R - A*Q' */ z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "Conjugate transpose", m, n, n, &z__1, &a[a_offset] , lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda); /* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */ resid = zlange_("1", m, n, &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*Q - Z'*B */ zgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[ z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb); z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb, &q[q_offset], lda, &z__1, &bwk[bwk_offset], ldb); /* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */ resid = zlange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]); if (bnorm > 0.) { /* Computing MAX */ i__1 = max(1,*p); result[2] = resid / (doublereal) max(i__1,*m) / bnorm / ulp; } else { result[2] = 0.; } /* Compute I - Q*Q' */ zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda); zherk_("Upper", "No 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 ZGRQTS */ } /* zgrqts_ */
/* Subroutine */ int zrqt03_(integer *m, integer *n, integer *k, doublecomplex *af, doublecomplex *c__, doublecomplex *cc, doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, doublereal *rwork, doublereal *result) { /* Initialized data */ static integer iseed[4] = { 1988,1989,1990,1991 }; /* System generated locals */ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1, q_offset, i__1, i__2; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static char side[1]; static integer info, j, iside; extern logical lsame_(char *, char *); static doublereal resid; static integer minmn; static doublereal cnorm; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static char trans[1]; static integer mc, nc; extern doublereal dlamch_(char *), zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); static integer itrans; extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlarnv_( integer *, integer *, integer *, doublecomplex *), zungrq_( integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmrq_( char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); static doublereal eps; #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1 #define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZRQT03 tests ZUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. ZRQT03 compares the results of a call to ZUNMRQ with the results of forming Q explicitly by a call to ZUNGRQ and then performing matrix multiplication by a call to ZGEMM. Arguments ========= M (input) INTEGER The number of rows or columns of the matrix C; C is n-by-m if Q is applied from the left, or m-by-n if Q is applied from the right. M >= 0. N (input) INTEGER The order of the orthogonal matrix Q. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the orthogonal matrix Q. N >= K >= 0. AF (input) COMPLEX*16 array, dimension (LDA,N) Details of the RQ factorization of an m-by-n matrix, as returned by ZGERQF. See CGERQF for further details. C (workspace) COMPLEX*16 array, dimension (LDA,N) CC (workspace) COMPLEX*16 array, dimension (LDA,N) Q (workspace) COMPLEX*16 array, dimension (LDA,N) LDA (input) INTEGER The leading dimension of the arrays AF, C, CC, and Q. TAU (input) COMPLEX*16 array, dimension (min(M,N)) The scalar factors of the elementary reflectors corresponding to the RQ factorization in AF. WORK (workspace) COMPLEX*16 array, dimension (LWORK) LWORK (input) INTEGER The length of WORK. LWORK must be at least M, and should be M*NB, where NB is the blocksize for this environment. RWORK (workspace) DOUBLE PRECISION array, dimension (M) RESULT (output) DOUBLE PRECISION array, dimension (4) The test ratios compare two techniques for multiplying a random matrix C by an n-by-n orthogonal matrix Q. RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) ===================================================================== Parameter adjustments */ q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; cc_dim1 = *lda; cc_offset = 1 + cc_dim1 * 1; cc -= cc_offset; c_dim1 = *lda; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; --tau; --work; --rwork; --result; /* Function Body */ eps = dlamch_("Epsilon"); minmn = min(*m,*n); /* Quick return if possible */ if (minmn == 0) { result[1] = 0.; result[2] = 0.; result[3] = 0.; result[4] = 0.; return 0; } /* Copy the last k rows of the factorization to the array Q */ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda); if (*k > 0 && *n > *k) { i__1 = *n - *k; zlacpy_("Full", k, &i__1, &af_ref(*m - *k + 1, 1), lda, &q_ref(*n - * k + 1, 1), lda); } if (*k > 1) { i__1 = *k - 1; i__2 = *k - 1; zlacpy_("Lower", &i__1, &i__2, &af_ref(*m - *k + 2, *n - *k + 1), lda, &q_ref(*n - *k + 2, *n - *k + 1), lda); } /* Generate the n-by-n matrix Q */ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6); zungrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork, &info); for (iside = 1; iside <= 2; ++iside) { if (iside == 1) { *(unsigned char *)side = 'L'; mc = *n; nc = *m; } else { *(unsigned char *)side = 'R'; mc = *m; nc = *n; } /* Generate MC by NC matrix C */ i__1 = nc; for (j = 1; j <= i__1; ++j) { zlarnv_(&c__2, iseed, &mc, &c___ref(1, j)); /* L10: */ } cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]); if (cnorm == 0.) { cnorm = 1.; } for (itrans = 1; itrans <= 2; ++itrans) { if (itrans == 1) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'C'; } /* Copy C */ zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset], lda); /* Apply Q or Q' to C */ s_copy(srnamc_1.srnamt, "ZUNMRQ", (ftnlen)6, (ftnlen)6); if (*k > 0) { zunmrq_(side, trans, &mc, &nc, k, &af_ref(*m - *k + 1, 1), lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[ 1], lwork, &info); } /* Form explicit product and subtract */ if (lsame_(side, "L")) { zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[ cc_offset], lda); } else { zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[ cc_offset], lda); } /* Compute error in the difference */ resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]); result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,* n) * cnorm * eps); /* L20: */ } /* L30: */ } return 0; /* End of ZRQT03 */ } /* zrqt03_ */
/* Subroutine */ int zrqt01_(integer *m, integer *n, doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *r__, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal * rwork, doublereal *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1, r_offset, i__1, i__2; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ doublereal eps; integer info; doublereal resid, anorm; integer minmn; 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 *); extern /* Subroutine */ int zgerqf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer * ), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, integer *, doublereal *); extern /* Subroutine */ int 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 */ /* ======= */ /* ZRQT01 tests ZGERQF, which computes the RQ factorization of an m-by-n */ /* matrix A, and partially tests ZUNGRQ which forms the n-by-n */ /* orthogonal matrix Q. */ /* ZRQT01 compares R with A*Q', and checks that Q is orthogonal. */ /* 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) COMPLEX*16 array, dimension (LDA,N) */ /* The m-by-n matrix A. */ /* AF (output) COMPLEX*16 array, dimension (LDA,N) */ /* Details of the RQ factorization of A, as returned by ZGERQF. */ /* See ZGERQF for further details. */ /* Q (output) COMPLEX*16 array, dimension (LDA,N) */ /* The n-by-n orthogonal matrix Q. */ /* R (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */ /* LDA (input) INTEGER */ /* The leading dimension of the arrays A, AF, Q and L. */ /* LDA >= max(M,N). */ /* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors, as returned */ /* by ZGERQF. */ /* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */ /* RESULT (output) DOUBLE PRECISION array, dimension (2) */ /* The test ratios: */ /* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */ /* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. 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; --tau; --work; --rwork; --result; /* Function Body */ minmn = min(*m,*n); eps = dlamch_("Epsilon"); /* Copy the matrix A to the array AF. */ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda); /* Factorize the matrix A in the array AF. */ s_copy(srnamc_1.srnamt, "ZGERQF", (ftnlen)6, (ftnlen)6); zgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info); /* Copy details of Q */ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda); if (*m <= *n) { if (*m > 0 && *m < *n) { i__1 = *n - *m; zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 + q_dim1], lda); } if (*m > 1) { i__1 = *m - 1; i__2 = *m - 1; zlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2], lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda); } } else { if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; zlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, & q[q_dim1 + 2], lda); } } /* Generate the n-by-n matrix Q */ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6); zungrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info); /* Copy R */ zlaset_("Full", m, n, &c_b12, &c_b12, &r__[r_offset], lda); if (*m <= *n) { if (*m > 0) { zlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, & r__[(*n - *m + 1) * r_dim1 + 1], lda); } } else { if (*m > *n && *n > 0) { i__1 = *m - *n; zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda); } if (*n > 0) { zlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - *n + 1 + r_dim1], lda); } } /* Compute R - A*Q' */ zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b19, &a[ a_offset], lda, &q[q_offset], lda, &c_b20, &r__[r_offset], lda); /* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]); resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]); if (anorm > 0.) { result[1] = resid / (doublereal) max(1,*n) / anorm / eps; } else { result[1] = 0.; } /* Compute I - Q*Q' */ zlaset_("Full", n, n, &c_b12, &c_b20, &r__[r_offset], lda); zherk_("Upper", "No transpose", n, n, &c_b28, &q[q_offset], lda, &c_b29, & r__[r_offset], lda); /* Compute norm( I - Q*Q' ) / ( N * EPS ) . */ resid = zlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]); result[2] = resid / (doublereal) max(1,*n) / eps; return 0; /* End of ZRQT01 */ } /* zrqt01_ */
/* 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_ */