/* Subroutine */ int drqt03_(integer *m, integer *n, integer *k, doublereal *
af, doublereal *c__, doublereal *cc, doublereal *q, integer *lda,
doublereal *tau, doublereal *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;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer iside;
extern logical lsame_(char *, char *);
static doublereal resid;
static integer minmn;
static doublereal cnorm;
static char trans[1];
static integer mc, nc;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *), dorgrq_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
static integer itrans;
extern /* Subroutine */ int dormrq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static doublereal eps;
#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
/* -- 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
=======
DRQT03 tests DORMRQ, which computes Q*C, Q'*C, C*Q or C*Q'.
DRQT03 compares the results of a call to DORMRQ with the results of
forming Q explicitly by a call to DORGRQ and then performing matrix
multiplication by a call to DGEMM.
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) DOUBLE PRECISION array, dimension (LDA,N)
Details of the RQ factorization of an m-by-n matrix, as
returned by DGERQF. See SGERQF for further details.
C (workspace) DOUBLE PRECISION array, dimension (LDA,N)
CC (workspace) DOUBLE PRECISION array, dimension (LDA,N)
Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
LDA (input) INTEGER
The leading dimension of the arrays AF, C, CC, and Q.
TAU (input) DOUBLE PRECISION array, dimension (min(M,N))
The scalar factors of the elementary reflectors corresponding
to the RQ factorization in AF.
WORK (workspace) DOUBLE PRECISION 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 */
dlaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
if (*k > 0 && *n > *k) {
i__1 = *n - *k;
dlacpy_("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;
dlacpy_("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, "DORGRQ", (ftnlen)6, (ftnlen)6);
dorgrq_(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) {
dlarnv_(&c__2, iseed, &mc, &c___ref(1, j));
/* L10: */
}
cnorm = dlange_("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 = 'T';
}
/* Copy C */
dlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "DORMRQ", (ftnlen)6, (ftnlen)6);
if (*k > 0) {
dormrq_(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")) {
dgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b22, &q[
q_offset], lda, &c__[c_offset], lda, &c_b23, &cc[
cc_offset], lda);
} else {
dgemm_("No transpose", trans, &mc, &nc, &nc, &c_b22, &c__[
c_offset], lda, &q[q_offset], lda, &c_b23, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = dlange_("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 DRQT03 */
} /* drqt03_ */
/* Subroutine */ int dgqrts_(integer *n, integer *m, integer *p, doublereal *
a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
doublereal *taua, doublereal *b, doublereal *bf, doublereal *z__,
doublereal *t, doublereal *bwk, integer *ldb, doublereal *taub,
doublereal *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;
/* Local variables */
static integer info;
static doublereal unfl;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal resid, anorm, bnorm;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dggqrf_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dlacpy_(char *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dorgrq_(integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *);
static doublereal ulp;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
#define bf_ref(a_1,a_2) bf[(a_2)*bf_dim1 + a_1]
/* -- 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
=======
DGQRTS tests DGGQRF, 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) DOUBLE PRECISION array, dimension (LDA,M)
The N-by-M matrix A.
AF (output) DOUBLE PRECISION array, dimension (LDA,N)
Details of the GQR factorization of A and B, as returned
by DGGQRF, see SGGQRF for further details.
Q (output) DOUBLE PRECISION array, dimension (LDA,N)
The M-by-M orthogonal matrix Q.
R (workspace) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by DGGQRF.
B (input) DOUBLE PRECISION array, dimension (LDB,P)
On entry, the N-by-P matrix A.
BF (output) DOUBLE PRECISION array, dimension (LDB,N)
Details of the GQR factorization of A and B, as returned
by DGGQRF, see SGGQRF for further details.
Z (output) DOUBLE PRECISION array, dimension (LDB,P)
The P-by-P orthogonal matrix Z.
T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N))
BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the arrays B, BF, Z and T.
LDB >= max(P,N).
TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
The scalar factors of the elementary reflectors, as returned
by DGGRQF.
WORK (workspace) DOUBLE PRECISION 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 )
=====================================================================
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. */
dlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
dlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
d__1 = dlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Computing MAX */
d__1 = dlange_("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. */
dggqrf_(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 */
dlaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda);
i__1 = *n - 1;
dlacpy_("Lower", &i__1, m, &af_ref(2, 1), lda, &q_ref(2, 1), lda);
i__1 = min(*n,*m);
dorgqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
dlaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb);
if (*n <= *p) {
if (*n > 0 && *n < *p) {
i__1 = *p - *n;
dlacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z___ref(*p - *n +
1, 1), ldb);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlacpy_("Lower", &i__1, &i__2, &bf_ref(2, *p - *n + 1), ldb, &
z___ref(*p - *n + 2, *p - *n + 1), ldb);
}
} else {
if (*p > 1) {
i__1 = *p - 1;
i__2 = *p - 1;
dlacpy_("Lower", &i__1, &i__2, &bf_ref(*n - *p + 2, 1), ldb, &
z___ref(2, 1), ldb);
}
}
i__1 = min(*n,*p);
dorgrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
dlaset_("Full", n, m, &c_b19, &c_b19, &r__[r_offset], lda);
dlacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
/* Copy T */
dlaset_("Full", n, p, &c_b19, &c_b19, &t[t_offset], ldb);
if (*n <= *p) {
dlacpy_("Upper", n, n, &bf_ref(1, *p - *n + 1), ldb, &t_ref(1, *p - *
n + 1), ldb);
} else {
i__1 = *n - *p;
dlacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
dlacpy_("Upper", p, p, &bf_ref(*n - *p + 1, 1), ldb, &t_ref(*n - *p +
1, 1), ldb);
}
/* Compute R - Q'*A */
dgemm_("Transpose", "No transpose", n, m, n, &c_b30, &q[q_offset], lda, &
a[a_offset], lda, &c_b31, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = dlange_("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 */
dgemm_("No Transpose", "No transpose", n, p, p, &c_b31, &t[t_offset], ldb,
&z__[z_offset], ldb, &c_b19, &bwk[bwk_offset], ldb);
dgemm_("Transpose", "No transpose", n, p, n, &c_b30, &q[q_offset], lda, &
b[b_offset], ldb, &c_b31, &bwk[bwk_offset], ldb);
/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = dlange_("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 */
dlaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda);
dsyrk_("Upper", "Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, &
r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = dlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (doublereal) max(1,*n) / ulp;
/* Compute I - Z'*Z */
dlaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb);
dsyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, &
t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = dlansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (doublereal) max(1,*p) / ulp;
return 0;
/* End of DGQRTS */
} /* dgqrts_ */
/* Subroutine */ int drqt02_(integer *m, integer *n, integer *k, doublereal *
a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
doublereal *tau, doublereal *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;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
doublereal resid, anorm;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dorgrq_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, 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 */
/* ======= */
/* DRQT02 tests DORGRQ, 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, DRQT02 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by DRQT01. */
/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by DGERQF. */
/* See DGERQF for further details. */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* R (workspace) DOUBLE PRECISION array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) DOUBLE PRECISION array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) DOUBLE PRECISION 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 */
dlaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
dlacpy_("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;
dlacpy_("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, "DORGRQ", (ftnlen)6, (ftnlen)6);
dorgrq_(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) */
dlaset_("Full", k, m, &c_b10, &c_b10, &r__[*m - *k + 1 + (*n - *m + 1) *
r_dim1], lda);
dlacpy_("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)' */
dgemm_("No transpose", "Transpose", k, m, n, &c_b15, &a[*m - *k + 1 +
a_dim1], lda, &q[q_offset], lda, &c_b16, &r__[*m - *k + 1 + (*n -
*m + 1) * r_dim1], lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = dlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
resid = dlange_("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' */
dlaset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
dsyrk_("Upper", "No transpose", m, n, &c_b15, &q[q_offset], lda, &c_b16, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = dlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of DRQT02 */
} /* drqt02_ */
/* Subroutine */ int drqt01_(integer *m, integer *n, doublereal *a,
doublereal *af, doublereal *q, doublereal *r__, integer *lda,
doublereal *tau, doublereal *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;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
doublereal resid, anorm;
integer minmn;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dgerqf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *), dlaset_(char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dorgrq_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, 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 */
/* ======= */
/* DRQT01 tests DGERQF, which computes the RQ factorization of an m-by-n */
/* matrix A, and partially tests DORGRQ which forms the n-by-n */
/* orthogonal matrix Q. */
/* DRQT01 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by DGERQF. */
/* See DGERQF for further details. */
/* Q (output) DOUBLE PRECISION array, dimension (LDA,N) */
/* The n-by-n orthogonal matrix Q. */
/* R (workspace) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by DGERQF. */
/* WORK (workspace) DOUBLE PRECISION 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. */
dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "DGERQF", (ftnlen)6, (ftnlen)6);
dgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
dlaset_("Full", n, n, &c_b6, &c_b6, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
dlacpy_("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;
dlacpy_("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;
dlacpy_("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, "DORGRQ", (ftnlen)6, (ftnlen)6);
dorgrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy R */
dlaset_("Full", m, n, &c_b13, &c_b13, &r__[r_offset], lda);
if (*m <= *n) {
if (*m > 0) {
dlacpy_("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;
dlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset],
lda);
}
if (*n > 0) {
dlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m -
*n + 1 + r_dim1], lda);
}
}
/* Compute R - A*Q' */
dgemm_("No transpose", "Transpose", m, n, n, &c_b20, &a[a_offset], lda, &
q[q_offset], lda, &c_b21, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */
anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = dlange_("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' */
dlaset_("Full", n, n, &c_b13, &c_b21, &r__[r_offset], lda);
dsyrk_("Upper", "No transpose", n, n, &c_b20, &q[q_offset], lda, &c_b21, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = dlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of DRQT01 */
} /* drqt01_ */
