/* Subroutine */
int cgglse_(integer *m, integer *n, integer *p, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, complex *d__, complex *x, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctrmv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), cggrqf_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
integer lwkmin;
extern /* Subroutine */
int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *), cunmrq_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int ctrtrs_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. 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;
--c__;
--d__;
--x;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*p < 0 || *p > *n || *p < *n - *m)
{
*info = -3;
}
else if (*lda < max(1,*m))
{
*info = -5;
}
else if (*ldb < max(1,*p))
{
*info = -7;
}
/* Calculate workspace */
if (*info == 0)
{
if (*n == 0)
{
lwkmin = 1;
lwkopt = 1;
}
else
{
nb1 = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "CUNMQR", " ", m, n, p, &c_n1);
nb4 = ilaenv_(&c__1, "CUNMRQ", " ", m, n, p, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
i__1 = max(i__1,nb3); // , expr subst
nb = max(i__1,nb4);
lwkmin = *m + *n + *p;
lwkopt = *p + mn + max(*m,*n) * nb;
}
work[1].r = (real) lwkopt;
work[1].i = 0.f; // , expr subst
if (*lwork < lwkmin && ! lquery)
{
*info = -12;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGGLSE", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Compute the GRQ factorization of matrices B and A: */
/* B*Q**H = ( 0 T12 ) P Z**H*A*Q**H = ( R11 R12 ) N-P */
/* N-P P ( 0 R22 ) M+P-N */
/* N-P P */
/* where T12 and R11 are upper triangular, and Q and Z are */
/* unitary. */
i__1 = *lwork - *p - mn;
cggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p + 1], &work[*p + mn + 1], &i__1, info);
i__1 = *p + mn + 1;
lopt = work[i__1].r;
/* Update c = Z**H *c = ( c1 ) N-P */
/* ( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
cunmqr_("Left", "Conjugate Transpose", m, &c__1, &mn, &a[a_offset], lda, & work[*p + 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
/* Computing MAX */
i__3 = *p + mn + 1;
i__1 = lopt;
i__2 = (integer) work[i__3].r; // , expr subst
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
if (*p > 0)
{
ctrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p + 1) * b_dim1 + 1], ldb, &d__[1], p, info);
if (*info > 0)
{
*info = 1;
return 0;
}
/* Put the solution in X */
ccopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Update c1 */
i__1 = *n - *p;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__1, p, &q__1, &a[(*n - *p + 1) * a_dim1 + 1] , lda, &d__[1], &c__1, &c_b1, &c__[1], &c__1);
}
/* Solve R11*x1 = c1 for x1 */
if (*n > *p)
{
i__1 = *n - *p;
i__2 = *n - *p;
ctrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[ a_offset], lda, &c__[1], &i__2, info);
if (*info > 0)
{
*info = 2;
return 0;
}
/* Put the solutions in X */
i__1 = *n - *p;
ccopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
}
/* Compute the residual vector: */
if (*m < *n)
{
nr = *m + *p - *n;
if (nr > 0)
{
i__1 = *n - *m;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &nr, &i__1, &q__1, &a[*n - *p + 1 + (*m + 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b1, &c__[*n - * p + 1], &c__1);
}
}
else
{
nr = *p;
}
if (nr > 0)
{
ctrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n - *p + 1) * a_dim1], lda, &d__[1], &c__1);
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
caxpy_(&nr, &q__1, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
}
/* Backward transformation x = Q**H*x */
i__1 = *lwork - *p - mn;
cunmrq_("Left", "Conjugate Transpose", n, &c__1, p, &b[b_offset], ldb, & work[1], &x[1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__4 = *p + mn + 1;
i__2 = lopt;
i__3 = (integer) work[i__4].r; // , expr subst
i__1 = *p + mn + max(i__2,i__3);
work[1].r = (real) i__1;
work[1].i = 0.f; // , expr subst
return 0;
/* End of CGGLSE */
}
/* Subroutine */ int cgrqts_(integer *m, integer *p, integer *n, complex *a,
complex *af, complex *q, complex *r__, integer *lda, complex *taua,
complex *b, complex *bf, complex *z__, complex *t, complex *bwk,
integer *ldb, complex *taub, complex *work, integer *lwork, real *
rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
real r__1;
complex q__1;
/* Local variables */
static integer info;
static real unfl;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm, bnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int cggrqf_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
complex *, integer *, integer *), clacpy_(char *, integer *,
integer *, complex *, integer *, complex *, integer *),
claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), cungqr_(integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
integer *), cungrq_(integer *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
static real 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
=======
CGRQTS tests CGGRQF, 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 array, dimension (LDA,N)
The M-by-N matrix A.
AF (output) COMPLEX array, dimension (LDA,N)
Details of the GRQ factorization of A and B, as returned
by CGGRQF, see CGGRQF for further details.
Q (output) COMPLEX array, dimension (LDA,N)
The N-by-N unitary matrix Q.
R (workspace) COMPLEX 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 array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by SGGQRC.
B (input) COMPLEX array, dimension (LDB,N)
On entry, the P-by-N matrix A.
BF (output) COMPLEX array, dimension (LDB,N)
Details of the GQR factorization of A and B, as returned
by CGGRQF, see CGGRQF for further details.
Z (output) REAL array, dimension (LDB,P)
The P-by-P unitary matrix Z.
T (workspace) COMPLEX array, dimension (LDB,max(P,N))
BWK (workspace) COMPLEX 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 array, dimension (min(P,N))
The scalar factors of the elementary reflectors, as returned
by SGGRQF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK, LWORK >= max(M,P,N)**2.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL 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 = slamch_("Precision");
unfl = slamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
/* Computing MAX */
r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
bnorm = dmax(r__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
cggrqf_(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 */
claset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
clacpy_("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;
clacpy_("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;
clacpy_("Lower", &i__1, &i__2, &af_ref(*m - *n + 2, 1), lda, &
q_ref(2, 1), lda);
}
}
i__1 = min(*m,*n);
cungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
claset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*p > 1) {
i__1 = *p - 1;
clacpy_("Lower", &i__1, n, &bf_ref(2, 1), ldb, &z___ref(2, 1), ldb);
}
i__1 = min(*p,*n);
cungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
claset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
if (*m <= *n) {
clacpy_("Upper", m, m, &af_ref(1, *n - *m + 1), lda, &r___ref(1, *n -
*m + 1), lda);
} else {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
clacpy_("Upper", n, n, &af_ref(*m - *n + 1, 1), lda, &r___ref(*m - *n
+ 1, 1), lda);
}
/* Copy T */
claset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
clacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
/* Compute R - A*Q' */
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", m, n, n, &q__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 = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.f;
}
/* Compute T*Q - Z'*B */
cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
&q[q_offset], lda, &q__1, &bwk[bwk_offset], ldb);
/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = clange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (real) max(i__1,*m) / bnorm / ulp;
} else {
result[2] = 0.f;
}
/* Compute I - Q*Q' */
claset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
cherk_("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 = clanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (real) max(1,*n) / ulp;
/* Compute I - Z'*Z */
claset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
cherk_("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 = clanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (real) max(1,*p) / ulp;
return 0;
/* End of CGRQTS */
} /* cgrqts_ */
/* Subroutine */ int cgrqts_(integer *m, integer *p, integer *n, complex *a,
complex *af, complex *q, complex *r__, integer *lda, complex *taua,
complex *b, complex *bf, complex *z__, complex *t, complex *bwk,
integer *ldb, complex *taub, complex *work, integer *lwork, real *
rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
real r__1;
complex q__1;
/* Local variables */
real ulp;
integer info;
real unfl;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
real resid, anorm, bnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int cggrqf_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
complex *, integer *, integer *), clacpy_(char *, integer *,
integer *, complex *, integer *, complex *, integer *),
claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), cungqr_(integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
integer *), cungrq_(integer *, integer *, integer *, complex *,
integer *, complex *, complex *, 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 */
/* ======= */
/* CGRQTS tests CGGRQF, 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 array, dimension (LDA,N) */
/* The M-by-N matrix A. */
/* AF (output) COMPLEX array, dimension (LDA,N) */
/* Details of the GRQ factorization of A and B, as returned */
/* by CGGRQF, see CGGRQF for further details. */
/* Q (output) COMPLEX array, dimension (LDA,N) */
/* The N-by-N unitary matrix Q. */
/* R (workspace) COMPLEX 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 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by SGGQRC. */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* On entry, the P-by-N matrix A. */
/* BF (output) COMPLEX array, dimension (LDB,N) */
/* Details of the GQR factorization of A and B, as returned */
/* by CGGRQF, see CGGRQF for further details. */
/* Z (output) REAL array, dimension (LDB,P) */
/* The P-by-P unitary matrix Z. */
/* T (workspace) COMPLEX array, dimension (LDB,max(P,N)) */
/* BWK (workspace) COMPLEX 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 array, dimension (min(P,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by SGGRQF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK, LWORK >= max(M,P,N)**2. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL 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 ) */
/* ===================================================================== */
/* .. 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 = slamch_("Precision");
unfl = slamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
/* Computing MAX */
r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
bnorm = dmax(r__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
cggrqf_(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 */
claset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
clacpy_("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;
clacpy_("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;
clacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
q[q_dim1 + 2], lda);
}
}
i__1 = min(*m,*n);
cungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
claset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*p > 1) {
i__1 = *p - 1;
clacpy_("Lower", &i__1, n, &bf[bf_dim1 + 2], ldb, &z__[z_dim1 + 2],
ldb);
}
i__1 = min(*p,*n);
cungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
claset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
if (*m <= *n) {
clacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &r__[(*
n - *m + 1) * r_dim1 + 1], lda);
} else {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
clacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - *n
+ 1 + r_dim1], lda);
}
/* Copy T */
claset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
clacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
/* Compute R - A*Q' */
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "Conjugate transpose", m, n, n, &q__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 = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.f;
}
/* Compute T*Q - Z'*B */
cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
&q[q_offset], lda, &q__1, &bwk[bwk_offset], ldb);
/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = clange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (real) max(i__1,*m) / bnorm / ulp;
} else {
result[2] = 0.f;
}
/* Compute I - Q*Q' */
claset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
cherk_("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 = clanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (real) max(1,*n) / ulp;
/* Compute I - Z'*Z */
claset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
cherk_("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 = clanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (real) max(1,*p) / ulp;
return 0;
/* End of CGRQTS */
} /* cgrqts_ */