/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *d__,
doublereal *x, doublereal *y, doublereal *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;
/* Local variables */
integer i__, nb, np, nb1, nb2, nb3, nb4, lopt;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), dggqrf_(
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer lwkmin;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dormrq_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGGGLM 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N) */
/* On entry, D is the left hand side of the GLM equation. */
/* On exit, D is destroyed. */
/* X (output) DOUBLE PRECISION array, dimension (M) */
/* Y (output) DOUBLE PRECISION array, dimension (P) */
/* On exit, X and Y are the solutions of the GLM problem. */
/* WORK (workspace/output) DOUBLE PRECISION 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 */
/* DGEQRF, SGERQF, DORMQR and SORMRQ. */
/* 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, "DGEQRF", " ", n, m, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DGERQF", " ", n, m, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1);
nb4 = ilaenv_(&c__1, "DORMRQ", " ", 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] = (doublereal) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGGLM", &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 */
/* orthogonal. */
i__1 = *lwork - *m - np;
dggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ 1], &work[*m + np + 1], &i__1, info);
lopt = (integer) work[*m + np + 1];
/* Update left-hand-side vector d = Q'*d = ( d1 ) M */
/* ( d2 ) N-M */
i__1 = max(1,*n);
i__2 = *lwork - *m - np;
dormqr_("Left", "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__1 = lopt, i__2 = (integer) work[*m + np + 1];
lopt = max(i__1,i__2);
/* Solve T22*y2 = d2 for y2 */
if (*n > *m) {
i__1 = *n - *m;
i__2 = *n - *m;
dtrtrs_("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;
dcopy_(&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__) {
y[i__] = 0.;
/* L10: */
}
/* Update d1 = d1 - T12*y2 */
i__1 = *n - *m;
dgemv_("No transpose", m, &i__1, &c_b32, &b[(*m + *p - *n + 1) * b_dim1 +
1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1);
/* Solve triangular system: R11*x = d1 */
if (*m > 0) {
dtrtrs_("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 */
dcopy_(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;
dormrq_("Left", "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__1 = lopt, i__2 = (integer) work[*m + np + 1];
work[1] = (doublereal) (*m + np + max(i__1,i__2));
return 0;
/* End of DGGGLM */
} /* dggglm_ */
/* 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 dgglse_(integer *m, integer *n, integer *p, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *c__,
doublereal *d__, doublereal *x, doublereal *work, integer *lwork,
integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DGGLSE solves the linear equality-constrained least squares (LSE)
problem:
minimize || c - A*x ||_2 subject to B*x = d
where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
M-vector, and d is a given P-vector. It is assumed that
P <= N <= M+P, and
rank(B) = P and rank( ( A ) ) = N.
( ( B ) )
These conditions ensure that the LSE problem has a unique solution,
which is obtained using a GRQ factorization of the matrices B and A.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
P (input) INTEGER
The number of rows of the matrix B. 0 <= P <= N <= M+P.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B is destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
C (input/output) DOUBLE PRECISION array, dimension (M)
On entry, C contains the right hand side vector for the
least squares part of the LSE problem.
On exit, the residual sum of squares for the solution
is given by the sum of squares of elements N-P+1 to M of
vector C.
D (input/output) DOUBLE PRECISION array, dimension (P)
On entry, D contains the right hand side vector for the
constrained equation.
On exit, D is destroyed.
X (output) DOUBLE PRECISION array, dimension (N)
On exit, X is the solution of the LSE problem.
WORK (workspace/output) DOUBLE PRECISION 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,M+N+P).
For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
where NB is an upper bound for the optimal blocksizes for
DGEQRF, SGERQF, DORMQR and SORMRQ.
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.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b29 = -1.;
static doublereal c_b31 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer lopt;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), daxpy_(integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
, dtrmv_(char *, char *, char *, integer *, doublereal *, integer
*, doublereal *, integer *), dtrsv_(char *
, char *, char *, integer *, doublereal *, integer *, doublereal *
, integer *);
static integer nb, mn, nr;
extern /* Subroutine */ int dggrqf_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer nb1, nb2, nb3, nb4;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dormrq_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
static integer lwkopt;
static logical lquery;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--c__;
--d__;
--x;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1, (ftnlen)6, (ftnlen)1);
nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
lwkopt = *p + mn + max(*m,*n) * nb;
work[1] = (doublereal) lwkopt;
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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *m + *n + *p;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGLSE", &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' = ( 0 T12 ) P Z'*A*Q' = ( 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
orthogonal. */
i__1 = *lwork - *p - mn;
dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ 1], &work[*p + mn + 1], &i__1, info);
lopt = (integer) work[*p + mn + 1];
/* Update c = Z'*c = ( c1 ) N-P
( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
dormqr_("Left", "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__1 = lopt, i__2 = (integer) work[*p + mn + 1];
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
dtrsv_("Upper", "No transpose", "Non unit", p, &b_ref(1, *n - *p + 1),
ldb, &d__[1], &c__1);
/* Update c1 */
i__1 = *n - *p;
dgemv_("No transpose", &i__1, p, &c_b29, &a_ref(1, *n - *p + 1), lda, &
d__[1], &c__1, &c_b31, &c__[1], &c__1);
/* Sovle R11*x1 = c1 for x1 */
i__1 = *n - *p;
dtrsv_("Upper", "No transpose", "Non unit", &i__1, &a[a_offset], lda, &
c__[1], &c__1);
/* Put the solutions in X */
i__1 = *n - *p;
dcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Compute the residual vector: */
if (*m < *n) {
nr = *m + *p - *n;
i__1 = *n - *m;
dgemv_("No transpose", &nr, &i__1, &c_b29, &a_ref(*n - *p + 1, *m + 1)
, lda, &d__[nr + 1], &c__1, &c_b31, &c__[*n - *p + 1], &c__1);
} else {
nr = *p;
}
dtrmv_("Upper", "No transpose", "Non unit", &nr, &a_ref(*n - *p + 1, *n -
*p + 1), lda, &d__[1], &c__1);
daxpy_(&nr, &c_b29, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
/* Backward transformation x = Q'*x */
i__1 = *lwork - *p - mn;
dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
work[1] = (doublereal) (*p + mn + max(i__1,i__2));
return 0;
/* End of DGGLSE */
} /* dgglse_ */
/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *d__,
doublereal *x, doublereal *y, doublereal *work, integer *lwork,
integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DGGGLM 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N)
On entry, D is the left hand side of the GLM equation.
On exit, D is destroyed.
X (output) DOUBLE PRECISION array, dimension (M)
Y (output) DOUBLE PRECISION array, dimension (P)
On exit, X and Y are the solutions of the GLM problem.
WORK (workspace/output) DOUBLE PRECISION 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
DGEQRF, SGERQF, DORMQR and SORMRQ.
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.
===================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b32 = -1.;
static doublereal c_b34 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer lopt, i__;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), dtrsv_(char *,
char *, char *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer nb, np;
extern /* Subroutine */ int dggqrf_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer nb1, nb2, nb3, nb4;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dormrq_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
static integer lwkopt;
static logical lquery;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--d__;
--x;
--y;
--work;
/* Function Body */
*info = 0;
np = min(*n,*p);
nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "DGERQF", " ", n, m, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1, (ftnlen)6, (ftnlen)1);
nb4 = ilaenv_(&c__1, "DORMRQ", " ", n, m, p, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
lwkopt = *m + np + max(*n,*p) * nb;
work[1] = (doublereal) lwkopt;
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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n + *m + *p;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGGLM", &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
orthogonal. */
i__1 = *lwork - *m - np;
dggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ 1], &work[*m + np + 1], &i__1, info);
lopt = (integer) work[*m + np + 1];
/* Update left-hand-side vector d = Q'*d = ( d1 ) M
( d2 ) N-M */
i__1 = max(1,*n);
i__2 = *lwork - *m - np;
dormqr_("Left", "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__1 = lopt, i__2 = (integer) work[*m + np + 1];
lopt = max(i__1,i__2);
/* Solve T22*y2 = d2 for y2 */
i__1 = *n - *m;
dtrsv_("Upper", "No transpose", "Non unit", &i__1, &b_ref(*m + 1, *m + *p
- *n + 1), ldb, &d__[*m + 1], &c__1);
i__1 = *n - *m;
dcopy_(&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__) {
y[i__] = 0.;
/* L10: */
}
/* Update d1 = d1 - T12*y2 */
i__1 = *n - *m;
dgemv_("No transpose", m, &i__1, &c_b32, &b_ref(1, *m + *p - *n + 1), ldb,
&y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1);
/* Solve triangular system: R11*x = d1 */
dtrsv_("Upper", "No Transpose", "Non unit", m, &a[a_offset], lda, &d__[1],
&c__1);
/* Copy D to X */
dcopy_(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;
dormrq_("Left", "Transpose", p, &c__1, &np, &b_ref(max(i__1,i__2), 1),
ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &i__4, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*m + np + 1];
work[1] = (doublereal) (*m + np + max(i__1,i__2));
return 0;
/* End of DGGGLM */
} /* dggglm_ */
/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, doublereal *
a, integer *lda, doublereal *taua, doublereal *b, integer *ldb,
doublereal *taub, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
/* Local variables */
integer nb, nb1, nb2, nb3, lopt;
extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dgerqf_(integer *, integer *, doublereal *, integer *, doublereal
*, doublereal *, integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dormrq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A */
/* and a P-by-N matrix B: */
/* A = R*Q, B = Z*T*Q, */
/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */
/* matrix, and R and T assume one of the forms: */
/* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */
/* N-M M ( R21 ) N */
/* N */
/* where R12 or R21 is upper triangular, and */
/* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */
/* ( 0 ) P-N P N-P */
/* N */
/* where T11 is upper triangular. */
/* In particular, if B is square and nonsingular, the GRQ factorization */
/* of A and B implicitly gives the RQ factorization of A*inv(B): */
/* A*inv(B) = (R*inv(T))*Z' */
/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
/* transpose of the matrix Z. */
/* 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/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, if M <= N, the upper triangle of the subarray */
/* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */
/* if M > N, the elements on and above the (M-N)-th subdiagonal */
/* contain the M-by-N upper trapezoidal matrix R; the remaining */
/* elements, with the array TAUA, represent the orthogonal */
/* matrix Q as a product of elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Q (see Further Details). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, the elements on and above the diagonal of the array */
/* contain the min(P,N)-by-N upper trapezoidal matrix T (T is */
/* upper triangular if P >= N); the elements below the diagonal, */
/* with the array TAUB, represent the orthogonal matrix Z as a */
/* product of elementary reflectors (see Further Details). */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Z (see Further Details). */
/* WORK (workspace/output) DOUBLE PRECISION 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 >= max(N,M,P)*max(NB1,NB2,NB3), */
/* where NB1 is the optimal blocksize for the RQ factorization */
/* of an M-by-N matrix, NB2 is the optimal blocksize for the */
/* QR factorization of a P-by-N matrix, and NB3 is the optimal */
/* blocksize for a call of DORMRQ. */
/* 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 INF0= -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - taua * v * v' */
/* where taua is a real scalar, and v is a real vector with */
/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
/* A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */
/* To form Q explicitly, use LAPACK subroutine DORGRQ. */
/* To use Q to update another matrix, use LAPACK subroutine DORMRQ. */
/* The matrix Z is represented as a product of elementary reflectors */
/* Z = H(1) H(2) . . . H(k), where k = min(p,n). */
/* Each H(i) has the form */
/* H(i) = I - taub * v * v' */
/* where taub is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */
/* and taub in TAUB(i). */
/* To form Z explicitly, use LAPACK subroutine DORGQR. */
/* To use Z to update another matrix, use LAPACK subroutine DORMQR. */
/* ===================================================================== */
/* .. 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;
--taua;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--taub;
--work;
/* Function Body */
*info = 0;
nb1 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DGEQRF", " ", p, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
/* Computing MAX */
i__1 = max(*n,*m);
lwkopt = max(i__1,*p) * nb;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*p < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*p)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m), i__1 = max(i__1,*p);
if (*lwork < max(i__1,*n) && ! lquery) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGRQF", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* RQ factorization of M-by-N matrix A: A = R*Q */
dgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
lopt = (integer) work[1];
/* Update B := B*Q' */
i__1 = min(*m,*n);
/* Computing MAX */
i__2 = 1, i__3 = *m - *n + 1;
dormrq_("Right", "Transpose", p, n, &i__1, &a[max(i__2, i__3)+ a_dim1],
lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[1];
lopt = max(i__1,i__2);
/* QR factorization of P-by-N matrix B: B = Z*T */
dgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[1];
work[1] = (doublereal) max(i__1,i__2);
return 0;
/* End of DGGRQF */
} /* dggrqf_ */
/* Subroutine */ int dgerqs_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *tau, doublereal *b, integer *
ldb, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dlaset_(
char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *), dormrq_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
/* -- LAPACK 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
=======
Compute a minimum-norm solution
min || A*X - B ||
using the RQ factorization
A = R*Q
computed by DGERQF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= M >= 0.
NRHS (input) INTEGER
The number of columns of B. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
Details of the RQ factorization of the original matrix A as
returned by DGERQF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= M.
TAU (input) DOUBLE PRECISION array, dimension (M)
Details of the orthogonal matrix Q.
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the right hand side vectors for the linear system.
On exit, the solution vectors X. Each solution vector
is contained in rows 1:N of a column of B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
The length of the array WORK. LWORK must be at least NRHS,
and should be at least NRHS*NB, where NB is the block size
for this environment.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *m > *n) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGERQS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0 || *m == 0) {
return 0;
}
/* Solve R*X = B(n-m+1:n,:) */
dtrsm_("Left", "Upper", "No transpose", "Non-unit", m, nrhs, &c_b7, &
a_ref(1, *n - *m + 1), lda, &b_ref(*n - *m + 1, 1), ldb);
/* Set B(1:n-m,:) to zero */
i__1 = *n - *m;
dlaset_("Full", &i__1, nrhs, &c_b9, &c_b9, &b[b_offset], ldb);
/* B := Q' * B */
dormrq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &tau[1], &b[
b_offset], ldb, &work[1], lwork, info);
return 0;
/* End of DGERQS */
} /* dgerqs_ */
/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *c__,
doublereal *d__, doublereal *x, doublereal *work, integer *lwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
integer lwkmin;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGGLSE solves the linear equality-constrained least squares (LSE) */
/* problem: */
/* minimize || c - A*x ||_2 subject to B*x = d */
/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */
/* M-vector, and d is a given P-vector. It is assumed that */
/* P <= N <= M+P, and */
/* rank(B) = P and rank( (A) ) = N. */
/* ( (B) ) */
/* These conditions ensure that the LSE problem has a unique solution, */
/* which is obtained using a generalized RQ factorization of the */
/* matrices (B, A) given by */
/* B = (0 R)*Q, A = Z*T*Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the elements on and above the diagonal of the array */
/* contain the min(M,N)-by-N upper trapezoidal matrix T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */
/* contains the P-by-P upper triangular matrix R. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* C (input/output) DOUBLE PRECISION array, dimension (M) */
/* On entry, C contains the right hand side vector for the */
/* least squares part of the LSE problem. */
/* On exit, the residual sum of squares for the solution */
/* is given by the sum of squares of elements N-P+1 to M of */
/* vector C. */
/* D (input/output) DOUBLE PRECISION array, dimension (P) */
/* On entry, D contains the right hand side vector for the */
/* constrained equation. */
/* On exit, D is destroyed. */
/* X (output) DOUBLE PRECISION array, dimension (N) */
/* On exit, X is the solution of the LSE problem. */
/* WORK (workspace/output) DOUBLE PRECISION 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,M+N+P). */
/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */
/* where NB is an upper bound for the optimal blocksizes for */
/* DGEQRF, SGERQF, DORMQR and SORMRQ. */
/* 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 B in the */
/* generalized RQ factorization of the pair (B, A) is */
/* singular, so that rank(B) < P; the least squares */
/* solution could not be computed. */
/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */
/* T associated with A in the generalized RQ factorization */
/* of the pair (B, A) is singular, so that */
/* rank( (A) ) < N; the least squares solution could not */
/* ( (B) ) */
/* be computed. */
/* ===================================================================== */
/* 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, "DGEQRF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1);
nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, 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 = *p + mn + max(*m,*n) * nb;
}
work[1] = (doublereal) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGLSE", &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' = ( 0 T12 ) P Z'*A*Q' = ( 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 */
/* orthogonal. */
i__1 = *lwork - *p - mn;
dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ 1], &work[*p + mn + 1], &i__1, info);
lopt = (integer) work[*p + mn + 1];
/* Update c = Z'*c = ( c1 ) N-P */
/* ( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
dormqr_("Left", "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__1 = lopt, i__2 = (integer) work[*p + mn + 1];
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
if (*p > 0) {
dtrtrs_("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 */
dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Update c1 */
i__1 = *n - *p;
dgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 +
1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1);
}
/* Solve R11*x1 = c1 for x1 */
if (*n > *p) {
i__1 = *n - *p;
i__2 = *n - *p;
dtrtrs_("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;
dcopy_(&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;
dgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m +
1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n -
*p + 1], &c__1);
}
} else {
nr = *p;
}
if (nr > 0) {
dtrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n
- *p + 1) * a_dim1], lda, &d__[1], &c__1);
daxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
}
/* Backward transformation x = Q'*x */
i__1 = *lwork - *p - mn;
dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
work[1] = (doublereal) (*p + mn + max(i__1,i__2));
return 0;
/* End of DGGLSE */
} /* dgglse_ */
/* Subroutine */
int dggrqf_(integer *m, integer *p, integer *n, doublereal * a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, doublereal *taub, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
/* Local variables */
integer nb, nb1, nb2, nb3, lopt;
extern /* Subroutine */
int dgeqrf_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dgerqf_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int dormrq_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK computational 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 .. */
/* .. */
/* ===================================================================== */
/* .. 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;
--taua;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--taub;
--work;
/* Function Body */
*info = 0;
nb1 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DGEQRF", " ", p, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
/* Computing MAX */
i__1 = max(*n,*m);
lwkopt = max(i__1,*p) * nb;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
if (*m < 0)
{
*info = -1;
}
else if (*p < 0)
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*lda < max(1,*m))
{
*info = -5;
}
else if (*ldb < max(1,*p))
{
*info = -8;
}
else /* if(complicated condition) */
{
/* Computing MAX */
i__1 = max(1,*m);
i__1 = max(i__1,*p); // , expr subst
if (*lwork < max(i__1,*n) && ! lquery)
{
*info = -11;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DGGRQF", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* RQ factorization of M-by-N matrix A: A = R*Q */
dgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
lopt = (integer) work[1];
/* Update B := B*Q**T */
i__1 = min(*m,*n);
/* Computing MAX */
i__2 = 1;
i__3 = *m - *n + 1; // , expr subst
dormrq_("Right", "Transpose", p, n, &i__1, &a[max(i__2,i__3) + a_dim1], lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info);
/* Computing MAX */
i__1 = lopt;
i__2 = (integer) work[1]; // , expr subst
lopt = max(i__1,i__2);
/* QR factorization of P-by-N matrix B: B = Z*T */
dgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
/* Computing MAX */
i__1 = lopt;
i__2 = (integer) work[1]; // , expr subst
work[1] = (doublereal) max(i__1,i__2);
return 0;
/* End of DGGRQF */
}
