/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEQRF computes a QR factorization of a real M-by-N matrix A: */
/* A = Q * R. */
/* 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/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 R (R is */
/* upper triangular if m >= n); the elements below the diagonal, */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of min(m,n) elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (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). */
/* For optimum performance LWORK >= N*NB, where NB is */
/* the optimal blocksize. */
/* 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 */
/* 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 - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
/* and tau in TAU(i). */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
lwkopt = *n * nb;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQRF", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
if (k == 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1);
nx = max(i__1,i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
c_n1);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the QR factorization of the current block */
/* A(i:m,i:i+ib-1) */
i__3 = *m - i__ + 1;
dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *m - i__ + 1;
dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork);
/* Apply H' to A(i:m,i+ib:n) from the left */
i__3 = *m - i__ + 1;
i__4 = *n - i__ - ib + 1;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib
+ 1], &ldwork);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
work[1] = (doublereal) iws;
return 0;
/* End of DGEQRF */
} /* dgeqrf_ */
/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer *
lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info)
{
/* -- LAPACK test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DGEQPF computes a QR factorization with column pivoting of a
real M-by-N matrix A: A*P = Q*R.
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/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the upper triangle of the array contains the
min(M,N)-by-N upper triangular matrix R; the elements
below the diagonal, together with the array TAU,
represent the orthogonal matrix Q as a product of
min(m,n) elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of A*P (a leading column); if JPVT(i) = 0,
the i-th column of A is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -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(n)
Each H(i) has the form
H = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
The matrix P is represented in jpvt as follows: If
jpvt(j) = i
then the jth column of P is the ith canonical unit vector.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal temp2;
static integer i, j;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *);
static integer itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dgeqr2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
dorm2r_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
static integer ma, mn;
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal aii;
static integer pvt;
#define JPVT(I) jpvt[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (JPVT(i) != 0) {
if (i != itemp) {
dswap_(m, &A(1,i), &c__1, &A(1,itemp), &
c__1);
JPVT(i) = JPVT(itemp);
JPVT(itemp) = i;
} else {
JPVT(i) = i;
}
++itemp;
} else {
JPVT(i) = i;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
dgeqr2_(m, &ma, &A(1,1), lda, &TAU(1), &WORK(1), info);
if (ma < *n) {
i__1 = *n - ma;
dorm2r_("Left", "Transpose", m, &i__1, &ma, &A(1,1), lda, &
TAU(1), &A(1,ma+1), lda, &WORK(1), info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of
work store the exact column norms. */
i__1 = *n;
for (i = itemp + 1; i <= *n; ++i) {
i__2 = *m - itemp;
WORK(i) = dnrm2_(&i__2, &A(itemp+1,i), &c__1);
WORK(*n + i) = WORK(i);
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i = itemp + 1; i <= mn; ++i) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i + 1;
pvt = i - 1 + idamax_(&i__2, &WORK(i), &c__1);
if (pvt != i) {
dswap_(m, &A(1,pvt), &c__1, &A(1,i), &
c__1);
itemp = JPVT(pvt);
JPVT(pvt) = JPVT(i);
JPVT(i) = itemp;
WORK(pvt) = WORK(i);
WORK(*n + pvt) = WORK(*n + i);
}
/* Generate elementary reflector H(i) */
if (i < *m) {
i__2 = *m - i + 1;
dlarfg_(&i__2, &A(i,i), &A(i+1,i), &
c__1, &TAU(i));
} else {
dlarfg_(&c__1, &A(*m,*m), &A(*m,*m), &
c__1, &TAU(*m));
}
if (i < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
aii = A(i,i);
A(i,i) = 1.;
i__2 = *m - i + 1;
i__3 = *n - i;
dlarf_("LEFT", &i__2, &i__3, &A(i,i), &c__1, &TAU(
i), &A(i,i+1), lda, &WORK((*n << 1) +
1));
A(i,i) = aii;
}
/* Update partial column norms */
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
if (WORK(j) != 0.) {
/* Computing 2nd power */
d__2 = (d__1 = A(i,j), abs(d__1)) / WORK(j);
temp = 1. - d__2 * d__2;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = WORK(j) / WORK(*n + j);
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i > 0) {
i__3 = *m - i;
WORK(j) = dnrm2_(&i__3, &A(i+1,j), &
c__1);
WORK(*n + j) = WORK(j);
} else {
WORK(j) = 0.;
WORK(*n + j) = 0.;
}
} else {
WORK(j) *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of DGEQPF */
} /* dgeqpf_ */
doublereal dqrt14_(char *trans, integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
integer i__, j;
doublereal err;
integer info;
doublereal anrm;
logical tpsd;
doublereal xnrm;
extern logical lsame_(char *, char *);
doublereal rwork[1];
extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dgeqr2_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlacpy_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
integer ldwork;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQRT14 checks whether X is in the row space of A or A'. It does so */
/* by scaling both X and A such that their norms are in the range */
/* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X] */
/* (if TRANS = 'T') or an LQ factorization of [A',X]' (if TRANS = 'N'), */
/* and returning the norm of the trailing triangle, scaled by */
/* MAX(M,N,NRHS)*eps. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, check for X in the row space of A */
/* = 'T': Transpose, check for X in the row space of A'. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of X. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The M-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If TRANS = 'N', the N-by-NRHS matrix X. */
/* IF TRANS = 'T', the M-by-NRHS matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. */
/* WORK (workspace) DOUBLE PRECISION array dimension (LWORK) */
/* LWORK (input) INTEGER */
/* length of workspace array required */
/* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2); */
/* if TRANS = 'T', LWORK >= (N+NRHS)*(M+2). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--work;
/* Function Body */
ret_val = 0.;
if (lsame_(trans, "N")) {
ldwork = *m + *nrhs;
tpsd = FALSE_;
if (*lwork < (*m + *nrhs) * (*n + 2)) {
xerbla_("DQRT14", &c__10);
return ret_val;
} else if (*n <= 0 || *nrhs <= 0) {
return ret_val;
}
} else if (lsame_(trans, "T")) {
ldwork = *m;
tpsd = TRUE_;
if (*lwork < (*n + *nrhs) * (*m + 2)) {
xerbla_("DQRT14", &c__10);
return ret_val;
} else if (*m <= 0 || *nrhs <= 0) {
return ret_val;
}
} else {
xerbla_("DQRT14", &c__1);
return ret_val;
}
/* Copy and scale A */
dlacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
anrm = dlange_("M", m, n, &work[1], &ldwork, rwork);
if (anrm != 0.) {
dlascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
info);
}
/* Copy X or X' into the right place and scale it */
if (tpsd) {
/* Copy X into columns n+1:n+nrhs of work */
dlacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
ldwork);
xnrm = dlange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
if (xnrm != 0.) {
dlascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
ldwork + 1], &ldwork, &info);
}
i__1 = *n + *nrhs;
anrm = dlange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);
/* Compute QR factorization of X */
i__1 = *n + *nrhs;
/* Computing MIN */
i__2 = *m, i__3 = *n + *nrhs;
dgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
&work[ldwork * (*n + *nrhs) + min(i__2, i__3)+ 1], &info);
/* Compute largest entry in upper triangle of */
/* work(n+1:m,n+1:n+nrhs) */
err = 0.;
i__1 = *n + *nrhs;
for (j = *n + 1; j <= i__1; ++j) {
i__2 = min(*m,j);
for (i__ = *n + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = err, d__3 = (d__1 = work[i__ + (j - 1) * *m], abs(d__1)
);
err = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else {
/* Copy X' into rows m+1:m+nrhs of work */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
work[*m + j + (i__ - 1) * ldwork] = x[i__ + j * x_dim1];
/* L30: */
}
/* L40: */
}
xnrm = dlange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
;
if (xnrm != 0.) {
dlascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
&ldwork, &info);
}
/* Compute LQ factorization of work */
dgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
ldwork * (*n + 1) + 1], &info);
/* Compute largest entry in lower triangle in */
/* work(m+1:m+nrhs,m+1:n) */
err = 0.;
i__1 = *n;
for (j = *m + 1; j <= i__1; ++j) {
i__2 = ldwork;
for (i__ = j; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = err, d__3 = (d__1 = work[i__ + (j - 1) * ldwork], abs(
d__1));
err = max(d__2,d__3);
/* L50: */
}
/* L60: */
}
}
/* Computing MAX */
i__1 = max(*m,*n);
ret_val = err / ((doublereal) max(i__1,*nrhs) * dlamch_("Epsilon"));
return ret_val;
/* End of DQRT14 */
} /* dqrt14_ */
/* Subroutine */ int derrqr_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[4] /* was [2][2] */, b[2];
integer i__, j;
doublereal w[2], x[2], af[4] /* was [2][2] */;
integer info;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dorg2r_(
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dorm2r_(char *, char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), alaesm_(char *, logical *, integer *),
dgeqrf_(integer *, integer *, doublereal *, integer *, doublereal
*, doublereal *, integer *, integer *), chkxer_(char *, integer *,
integer *, logical *, logical *), dgeqrs_(integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *),
dorgqr_(integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dormqr_(char *,
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRQR tests the error exits for the DOUBLE PRECISION routines */
/* that use the QR decomposition of a general matrix. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 2; ++j) {
for (i__ = 1; i__ <= 2; ++i__) {
a[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
af[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
/* L10: */
}
b[j - 1] = 0.;
w[j - 1] = 0.;
x[j - 1] = 0.;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for QR factorization */
/* DGEQRF */
s_copy(srnamc_1.srnamt, "DGEQRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGEQR2 */
s_copy(srnamc_1.srnamt, "DGEQR2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGEQRS */
s_copy(srnamc_1.srnamt, "DGEQRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORGQR */
s_copy(srnamc_1.srnamt, "DORGQR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dorgqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorgqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorgqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorgqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dorgqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORG2R */
s_copy(srnamc_1.srnamt, "DORG2R", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dorg2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorg2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorg2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorg2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorg2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorg2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORMQR */
s_copy(srnamc_1.srnamt, "DORMQR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dormqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dormqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dormqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dormqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dormqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dormqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dormqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORM2R */
s_copy(srnamc_1.srnamt, "DORM2R", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dorm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dorm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dorm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRQR */
} /* derrqr_ */
/* Subroutine */ int dggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer
*l, doublereal *u, integer *ldu, doublereal *v, integer *ldv,
doublereal *q, integer *ldq, integer *iwork, doublereal *tau,
doublereal *work, integer *info)
{
/* -- 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
=======
DGGSVP computes orthogonal matrices U, V and Q such that
N-K-L K L
U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
L ( 0 0 A23 )
M-K-L ( 0 0 0 )
N-K-L K L
= K ( 0 A12 A13 ) if M-K-L < 0;
M-K ( 0 0 A23 )
N-K-L K L
V'*B*Q = L ( 0 0 B13 )
P-L ( 0 0 0 )
where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
transpose of Z.
This decomposition is the preprocessing step for computing the
Generalized Singular Value Decomposition (GSVD), see subroutine
DGGSVD.
Arguments
=========
JOBU (input) CHARACTER*1
= 'U': Orthogonal matrix U is computed;
= 'N': U is not computed.
JOBV (input) CHARACTER*1
= 'V': Orthogonal matrix V is computed;
= 'N': V is not computed.
JOBQ (input) CHARACTER*1
= 'Q': Orthogonal matrix Q is computed;
= 'N': Q is not computed.
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, A contains the triangular (or trapezoidal) matrix
described in the Purpose section.
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 contains the triangular matrix described in
the Purpose section.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
TOLA (input) DOUBLE PRECISION
TOLB (input) DOUBLE PRECISION
TOLA and TOLB are the thresholds to determine the effective
numerical rank of matrix B and a subblock of A. Generally,
they are set to
TOLA = MAX(M,N)*norm(A)*MAZHEPS,
TOLB = MAX(P,N)*norm(B)*MAZHEPS.
The size of TOLA and TOLB may affect the size of backward
errors of the decomposition.
K (output) INTEGER
L (output) INTEGER
On exit, K and L specify the dimension of the subblocks
described in Purpose.
K + L = effective numerical rank of (A',B')'.
U (output) DOUBLE PRECISION array, dimension (LDU,M)
If JOBU = 'U', U contains the orthogonal matrix U.
If JOBU = 'N', U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,M) if
JOBU = 'U'; LDU >= 1 otherwise.
V (output) DOUBLE PRECISION array, dimension (LDV,M)
If JOBV = 'V', V contains the orthogonal matrix V.
If JOBV = 'N', V is not referenced.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,P) if
JOBV = 'V'; LDV >= 1 otherwise.
Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
If JOBQ = 'Q', Q contains the orthogonal matrix Q.
If JOBQ = 'N', Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N) if
JOBQ = 'Q'; LDQ >= 1 otherwise.
IWORK (workspace) INTEGER array, dimension (N)
TAU (workspace) DOUBLE PRECISION array, dimension (N)
WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The subroutine uses LAPACK subroutine DGEQPF for the QR factorization
with column pivoting to detect the effective numerical rank of the
a matrix. It may be replaced by a better rank determination strategy.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublereal c_b12 = 0.;
static doublereal c_b22 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
static logical wantq, wantu, wantv;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dgerq2_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dorg2r_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
dorm2r_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dormr2_(char *, char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), dgeqpf_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *), dlaset_(char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *), dlapmt_(logical *,
integer *, integer *, doublereal *, integer *, integer *);
static logical forwrd;
#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]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define v_ref(a_1,a_2) v[(a_2)*v_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;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--iwork;
--tau;
--work;
/* Function Body */
wantu = lsame_(jobu, "U");
wantv = lsame_(jobv, "V");
wantq = lsame_(jobq, "Q");
forwrd = TRUE_;
*info = 0;
if (! (wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (wantv || lsame_(jobv, "N"))) {
*info = -2;
} else if (! (wantq || lsame_(jobq, "N"))) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -8;
} else if (*ldb < max(1,*p)) {
*info = -10;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -16;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -18;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGSVP", &i__1);
return 0;
}
/* QR with column pivoting of B: B*P = V*( S11 S12 )
( 0 0 ) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
dgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
/* Update A := A*P */
dlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
/* Determine the effective rank of matrix B. */
*l = 0;
i__1 = min(*p,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = b_ref(i__, i__), abs(d__1)) > *tolb) {
++(*l);
}
/* L20: */
}
if (wantv) {
/* Copy the details of V, and form V. */
dlaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
if (*p > 1) {
i__1 = *p - 1;
dlacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv);
}
i__1 = min(*p,*n);
dorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
}
/* Clean up B */
i__1 = *l - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *l;
for (i__ = j + 1; i__ <= i__2; ++i__) {
b_ref(i__, j) = 0.;
/* L30: */
}
/* L40: */
}
if (*p > *l) {
i__1 = *p - *l;
dlaset_("Full", &i__1, n, &c_b12, &c_b12, &b_ref(*l + 1, 1), ldb);
}
if (wantq) {
/* Set Q = I and Update Q := Q*P */
dlaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
dlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
}
if (*p >= *l && *n != *l) {
/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
dgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z' */
dormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[
a_offset], lda, &work[1], info);
if (wantq) {
/* Update Q := Q*Z' */
dormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1],
&q[q_offset], ldq, &work[1], info);
}
/* Clean up B */
i__1 = *n - *l;
dlaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb);
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
i__2 = *l;
for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
b_ref(i__, j) = 0.;
/* L50: */
}
/* L60: */
}
}
/* Let N-L L
A = ( A11 A12 ) M,
then the following does the complete QR decomposition of A11:
A11 = U*( 0 T12 )*P1'
( 0 0 ) */
i__1 = *n - *l;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L70: */
}
i__1 = *n - *l;
dgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info);
/* Determine the effective rank of A11 */
*k = 0;
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = a_ref(i__, i__), abs(d__1)) > *tola) {
++(*k);
}
/* L80: */
}
/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
dorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &
a_ref(1, *n - *l + 1), lda, &work[1], info);
if (wantu) {
/* Copy the details of U, and form U */
dlaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
if (*m > 1) {
i__1 = *m - 1;
i__2 = *n - *l;
dlacpy_("Lower", &i__1, &i__2, &a_ref(2, 1), lda, &u_ref(2, 1),
ldu);
}
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
dorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
}
if (wantq) {
/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
i__1 = *n - *l;
dlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
}
/* Clean up A: set the strictly lower triangular part of
A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
i__1 = *k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = 0.;
/* L90: */
}
/* L100: */
}
if (*m > *k) {
i__1 = *m - *k;
i__2 = *n - *l;
dlaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a_ref(*k + 1, 1), lda);
}
if (*n - *l > *k) {
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
dgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
if (wantq) {
/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
i__1 = *n - *l;
dormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, &
tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up A */
i__1 = *n - *l - *k;
dlaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda);
i__1 = *n - *l;
for (j = *n - *l - *k + 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = 0.;
/* L110: */
}
/* L120: */
}
}
if (*m > *k) {
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
dgeqr2_(&i__1, l, &a_ref(*k + 1, *n - *l + 1), lda, &tau[1], &work[1],
info);
if (wantu) {
/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
i__1 = *m - *k;
/* Computing MIN */
i__3 = *m - *k;
i__2 = min(i__3,*l);
dorm2r_("Right", "No transpose", m, &i__1, &i__2, &a_ref(*k + 1, *
n - *l + 1), lda, &tau[1], &u_ref(1, *k + 1), ldu, &work[
1], info);
}
/* Clean up */
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = 0.;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of DGGSVP */
} /* dggsvp_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int dseupd_(logical *rvec, char *howmny, logical *select,
doublereal *d__, doublereal *z__, integer *ldz, doublereal *sigma,
char *bmat, integer *n, char *which, integer *nev, doublereal *tol,
doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer
*iparam, integer *ipntr, doublereal *workd, doublereal *workl,
integer *lworkl, integer *info, ftnlen howmny_len, ftnlen bmat_len,
ftnlen which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double pow_dd(doublereal *, doublereal *);
/* Local variables */
static integer j, k, ih, jj, iq, np, iw, ibd, ihb, ihd, ldh, ldq, irz;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer mode;
static doublereal eps23;
static integer ierr;
static doublereal temp;
static integer next;
static char type__[6];
static integer ritz;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal temp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static logical reord;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer nconv;
static doublereal rnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), ivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), dgeqr2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *);
static doublereal bnorm2;
extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
static integer bounds, msglvl, ishift, numcnv;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
dsesrt_(char *, logical *, integer *, doublereal *, integer *,
doublereal *, integer *, ftnlen), dsteqr_(char *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, ftnlen), dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen), dsgets_(integer *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
ftnlen);
static integer leftptr, rghtptr;
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
--workd;
--resid;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mseupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %--------------% */
/* | Quick return | */
/* %--------------% */
if (nconv == 0) {
goto L9000;
}
ierr = 0;
if (nconv <= 0) {
ierr = -14;
}
if (*n <= 0) {
ierr = -1;
}
if (*nev <= 0) {
ierr = -2;
}
if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
}
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SM", (
ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LA", (ftnlen)2, (
ftnlen)2) != 0 && s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) != 0 &&
s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
}
if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') {
ierr = -6;
}
if (*(unsigned char *)howmny != 'A' && *(unsigned char *)howmny != 'P' &&
*(unsigned char *)howmny != 'S' && *rvec) {
ierr = -15;
}
if (*rvec && *(unsigned char *)howmny == 'S') {
ierr = -16;
}
/* Computing 2nd power */
i__1 = *ncv;
if (*rvec && *lworkl < i__1 * i__1 + (*ncv << 3)) {
ierr = -7;
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
s_copy(type__, "BUCKLE", (ftnlen)6, (ftnlen)6);
} else if (mode == 5) {
s_copy(type__, "CAYLEY", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
if (*nev == 1 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
ierr = -12;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %-------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:2*ncv) := generated tridiagonal matrix H | */
/* | The subdiagonal is stored in workl(2:ncv). | */
/* | The dead spot is workl(1) but upon exiting | */
/* | dsaupd stores the B-norm of the last residual | */
/* | vector in workl(1). We use this !!! | */
/* | workl(2*ncv+1:2*ncv+ncv) := ritz values | */
/* | The wanted values are in the first NCONV spots. | */
/* | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | */
/* | The wanted values are in the first NCONV spots. | */
/* | NOTE: workl(1:4*ncv) is set by dsaupd and is not | */
/* | modified by dseupd . | */
/* %-------------------------------------------------------% */
/* %-------------------------------------------------------% */
/* | The following is used and set by dseupd . | */
/* | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | */
/* | computation of the eigenvectors of H. Stores | */
/* | the diagonal of H. Upon EXIT contains the NCV | */
/* | Ritz values of the original system. The first | */
/* | NCONV spots have the wanted values. If MODE = | */
/* | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | */
/* | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | */
/* | computation of the eigenvectors of H. Stores | */
/* | the subdiagonal of H. Upon EXIT contains the | */
/* | NCV corresponding Ritz estimates of the | */
/* | original system. The first NCONV spots have the | */
/* | wanted values. If MODE = 1,2 then will equal | */
/* | workl(3*ncv+1:4*ncv). | */
/* | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | */
/* | the eigenvector matrix for H as returned by | */
/* | dsteqr . Not referenced if RVEC = .False. | */
/* | Ordering follows that of workl(4*ncv+1:5*ncv) | */
/* | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | */
/* | Workspace. Needed by dsteqr and by dseupd . | */
/* | GRAND total of NCV*(NCV+8) locations. | */
/* %-------------------------------------------------------% */
ih = ipntr[5];
ritz = ipntr[6];
bounds = ipntr[7];
ldh = *ncv;
ldq = *ncv;
ihd = bounds + ldh;
ihb = ihd + ldh;
iq = ihb + ldh;
iw = iq + ldh * *ncv;
next = iw + (*ncv << 1);
ipntr[4] = next;
ipntr[8] = ihd;
ipntr[9] = ihb;
ipntr[10] = iq;
/* %----------------------------------------% */
/* | irz points to the Ritz values computed | */
/* | by _seigt before exiting _saup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _seigt before exiting | */
/* | _saup2. | */
/* %----------------------------------------% */
irz = ipntr[11] + *ncv;
ibd = irz + *ncv;
/* %---------------------------------% */
/* | Set machine dependent constant. | */
/* %---------------------------------% */
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
eps23 = pow_dd(&eps23, &c_b21);
/* %---------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* | BNORM2 is the 2 norm of B*RESID(1:N). | */
/* | Upon exit of dsaupd WORKD(1:N) has | */
/* | B*RESID(1:N). | */
/* %---------------------------------------% */
rnorm = workl[ih];
if (*(unsigned char *)bmat == 'I') {
bnorm2 = rnorm;
} else if (*(unsigned char *)bmat == 'G') {
bnorm2 = dnrm2_(n, &workd[1], &c__1);
}
if (msglvl > 2) {
dvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seupd: "
"Ritz values passed in from _SAUPD.", (ftnlen)42);
dvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_seupd: "
"Ritz estimates passed in from _SAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (doublereal) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
dsgets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], &workl[
1], (ftnlen)2);
if (msglvl > 2) {
dvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seu"
"pd: Ritz values after calling _SGETS.", (ftnlen)41);
dvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_seupd: Ritz value indices after calling _SGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = workl[irz + *ncv - j], abs(d__1));
temp1 = max(d__2,d__3);
jj = (integer) workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by _saupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the _saupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_seupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_seupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -17;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine _steqr to compute the eigenvalues and | */
/* | eigenvectors of the final symmetric tridiagonal matrix H. | */
/* | Initialize the eigenvector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = *ncv - 1;
dcopy_(&i__1, &workl[ih + 1], &c__1, &workl[ihb], &c__1);
dcopy_(ncv, &workl[ih + ldh], &c__1, &workl[ihd], &c__1);
dsteqr_("Identity", ncv, &workl[ihd], &workl[ihb], &workl[iq], &ldq, &
workl[iw], &ierr, (ftnlen)8);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
dcopy_(ncv, &workl[iq + *ncv - 1], &ldq, &workl[iw], &c__1);
dvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seu"
"pd: NCV Ritz values of the final H matrix", (ftnlen)45);
dvout_(&debug_1.logfil, ncv, &workl[iw], &debug_1.ndigit, "_seup"
"d: last row of the eigenvector matrix for H", (ftnlen)48);
}
if (reord) {
/* %---------------------------------------------% */
/* | Reordered the eigenvalues and eigenvectors | */
/* | computed by _steqr so that the "converged" | */
/* | eigenvalues appear in the first NCONV | */
/* | positions of workl(ihd), and the associated | */
/* | eigenvectors appear in the first NCONV | */
/* | columns. | */
/* %---------------------------------------------% */
leftptr = 1;
rghtptr = *ncv;
if (*ncv == 1) {
goto L30;
}
L20:
if (select[leftptr]) {
/* %-------------------------------------------% */
/* | Search, from the left, for the first Ritz | */
/* | value that has not converged. | */
/* %-------------------------------------------% */
++leftptr;
} else if (! select[rghtptr]) {
/* %----------------------------------------------% */
/* | Search, from the right, the first Ritz value | */
/* | that has converged. | */
/* %----------------------------------------------% */
--rghtptr;
} else {
/* %----------------------------------------------% */
/* | Swap the Ritz value on the left that has not | */
/* | converged with the Ritz value on the right | */
/* | that has converged. Swap the associated | */
/* | eigenvector of the tridiagonal matrix H as | */
/* | well. | */
/* %----------------------------------------------% */
temp = workl[ihd + leftptr - 1];
workl[ihd + leftptr - 1] = workl[ihd + rghtptr - 1];
workl[ihd + rghtptr - 1] = temp;
dcopy_(ncv, &workl[iq + *ncv * (leftptr - 1)], &c__1, &workl[
iw], &c__1);
dcopy_(ncv, &workl[iq + *ncv * (rghtptr - 1)], &c__1, &workl[
iq + *ncv * (leftptr - 1)], &c__1);
dcopy_(ncv, &workl[iw], &c__1, &workl[iq + *ncv * (rghtptr -
1)], &c__1);
++leftptr;
--rghtptr;
}
if (leftptr < rghtptr) {
goto L20;
}
L30:
;
}
if (msglvl > 2) {
dvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seu"
"pd: The eigenvalues of H--reordered", (ftnlen)39);
}
/* %----------------------------------------% */
/* | Load the converged Ritz values into D. | */
/* %----------------------------------------% */
dcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
} else {
/* %-----------------------------------------------------% */
/* | Ritz vectors not required. Load Ritz values into D. | */
/* %-----------------------------------------------------% */
dcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
dcopy_(ncv, &workl[ritz], &c__1, &workl[ihd], &c__1);
}
/* %------------------------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors and corresponding | */
/* | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | */
/* | (and corresponding data) are returned in ascending order. | */
/* %------------------------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
/* %---------------------------------------------------------% */
/* | Ascending sort of wanted Ritz values, vectors and error | */
/* | bounds. Not necessary if only Ritz values are desired. | */
/* %---------------------------------------------------------% */
if (*rvec) {
dsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq, (
ftnlen)2);
} else {
dcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1);
}
} else {
/* %-------------------------------------------------------------% */
/* | * Make a copy of all the Ritz values. | */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'BUCKLE' the transformation is | */
/* | lambda = sigma * theta / ( theta - 1 ) | */
/* | For TYPE = 'CAYLEY' the transformation is | */
/* | lambda = sigma * (theta + 1) / (theta - 1 ) | */
/* | where the theta are the Ritz values returned by dsaupd . | */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* | They are only reordered. | */
/* %-------------------------------------------------------------% */
dcopy_(ncv, &workl[ihd], &c__1, &workl[iw], &c__1);
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = 1. / workl[ihd + k - 1] + *sigma;
/* L40: */
}
} else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = *sigma * workl[ihd + k - 1] / (workl[ihd
+ k - 1] - 1.);
/* L50: */
}
} else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = *sigma * (workl[ihd + k - 1] + 1.) / (
workl[ihd + k - 1] - 1.);
/* L60: */
}
}
/* %-------------------------------------------------------------% */
/* | * Store the wanted NCONV lambda values into D. | */
/* | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | */
/* | into ascending order and apply sort to the NCONV theta | */
/* | values in the transformed system. We will need this to | */
/* | compute Ritz estimates in the original system. | */
/* | * Finally sort the lambda`s into ascending order and apply | */
/* | to Ritz vectors if wanted. Else just sort lambda`s into | */
/* | ascending order. | */
/* | NOTES: | */
/* | *workl(iw:iw+ncv-1) contain the theta ordered so that they | */
/* | match the ordering of the lambda. We`ll use them again for | */
/* | Ritz vector purification. | */
/* %-------------------------------------------------------------% */
dcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
dsortr_("LA", &c_true, &nconv, &workl[ihd], &workl[iw], (ftnlen)2);
if (*rvec) {
dsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq, (
ftnlen)2);
} else {
dcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1);
d__1 = bnorm2 / rnorm;
dscal_(ncv, &d__1, &workl[ihb], &c__1);
dsortr_("LA", &c_true, &nconv, &d__[1], &workl[ihb], (ftnlen)2);
}
}
/* %------------------------------------------------% */
/* | Compute the Ritz vectors. Transform the wanted | */
/* | eigenvectors of the symmetric tridiagonal H by | */
/* | the Lanczos basis matrix V. | */
/* %------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A') {
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(iq,ldq). | */
/* %----------------------------------------------------------% */
dgeqr2_(ncv, &nconv, &workl[iq], &ldq, &workl[iw + *ncv], &workl[ihb],
&ierr);
/* %--------------------------------------------------------% */
/* | * Postmultiply V by Q. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(ihd). | */
/* %--------------------------------------------------------% */
dorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[iq], &ldq, &
workl[iw + *ncv], &v[v_offset], ldv, &workd[*n + 1], &ierr, (
ftnlen)5, (ftnlen)11);
dlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
/* %-----------------------------------------------------% */
/* | In order to compute the Ritz estimates for the Ritz | */
/* | values in both systems, need the last row of the | */
/* | eigenvector matrix. Remember, it`s in factored form | */
/* %-----------------------------------------------------% */
i__1 = *ncv - 1;
for (j = 1; j <= i__1; ++j) {
workl[ihb + j - 1] = 0.;
/* L65: */
}
workl[ihb + *ncv - 1] = 1.;
dorm2r_("Left", "Transpose", ncv, &c__1, &nconv, &workl[iq], &ldq, &
workl[iw + *ncv], &workl[ihb], ncv, &temp, &ierr, (ftnlen)4, (
ftnlen)9);
} else if (*rvec && *(unsigned char *)howmny == 'S') {
/* Not yet implemented. See remark 2 above. */
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && *rvec) {
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[ihb + j - 1] = rnorm * (d__1 = workl[ihb + j - 1], abs(d__1)
);
/* L70: */
}
} else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && *rvec) {
/* %-------------------------------------------------% */
/* | * Determine Ritz estimates of the theta. | */
/* | If RVEC = .true. then compute Ritz estimates | */
/* | of the theta. | */
/* | If RVEC = .false. then copy Ritz estimates | */
/* | as computed by dsaupd . | */
/* | * Determine Ritz estimates of the lambda. | */
/* %-------------------------------------------------% */
dscal_(ncv, &bnorm2, &workl[ihb], &c__1);
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* Computing 2nd power */
d__2 = workl[iw + k - 1];
workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1], abs(d__1)) /
(d__2 * d__2);
/* L80: */
}
} else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* Computing 2nd power */
d__2 = workl[iw + k - 1] - 1.;
workl[ihb + k - 1] = *sigma * (d__1 = workl[ihb + k - 1], abs(
d__1)) / (d__2 * d__2);
/* L90: */
}
} else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1] / workl[iw +
k - 1] * (workl[iw + k - 1] - 1.), abs(d__1));
/* L100: */
}
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) {
dvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_seupd: U"
"ntransformed converged Ritz values", (ftnlen)43);
dvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seup"
"d: Ritz estimates of the untransformed Ritz values", (ftnlen)
55);
} else if (msglvl > 1) {
dvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_seupd: C"
"onverged Ritz values", (ftnlen)29);
dvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seup"
"d: Associated Ritz estimates", (ftnlen)33);
}
/* %-------------------------------------------------% */
/* | Ritz vector purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 3,4,5. See reference 7 | */
/* %-------------------------------------------------% */
if (*rvec && (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 || s_cmp(
type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0)) {
i__1 = nconv - 1;
for (k = 0; k <= i__1; ++k) {
workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / workl[iw + k];
/* L110: */
}
} else if (*rvec && s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = nconv - 1;
for (k = 0; k <= i__1; ++k) {
workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / (workl[iw + k] -
1.);
/* L120: */
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0) {
dger_(n, &nconv, &c_b110, &resid[1], &c__1, &workl[iw], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of dseupd | */
/* %---------------% */
} /* dseupd_ */
/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1;
/* Local variables */
integer i__, j, k, ib, nb, nt, nx, iws;
extern doublereal sceil_(real *);
integer nbmin, iinfo;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer lbwork, llwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* March 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEQRF computes a QR factorization of a real M-by-N matrix A: */
/* A = Q * R. */
/* This is the left-looking Level 3 BLAS version of the algorithm. */
/* 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/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 R (R is */
/* upper triangular if m >= n); the elements below the diagonal, */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of min(m,n) elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (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. The dimension can be divided into three parts. */
/* 1) The part for the triangular factor T. If the very last T is not bigger */
/* than any of the rest, then this part is NB x ceiling(K/NB), otherwise, */
/* NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T */
/* 2) The part for the very last T when T is bigger than any of the rest T. */
/* The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, */
/* where K = min(M,N), NX is calculated by */
/* NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) */
/* 3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB) */
/* So LWORK = part1 + part2 + part3 */
/* 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 */
/* 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 - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
/* and tau in TAU(i). */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
nbmin = 2;
nx = 0;
iws = *n;
k = min(*m,*n);
nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1);
nx = max(i__1,i__2);
}
/* Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: */
/* NB=3 2NB=6 K=10 */
/* | | | */
/* 1--2--3--4--5--6--7--8--9--10 */
/* | \________/ */
/* K-NX=5 NT=4 */
/* So here 4 x 4 is the last T stored in the workspace */
r__1 = (real) (k - nx) / (real) nb;
nt = k - sceil_(&r__1) * nb;
/* optimal workspace = space for dlarfb + space for normal T's + space for the last T */
/* Computing MAX */
/* Computing MAX */
i__3 = (*n - *m) * k, i__4 = (*n - *m) * nb;
/* Computing MAX */
i__5 = k * nb, i__6 = nb * nb;
i__1 = max(i__3,i__4), i__2 = max(i__5,i__6);
llwork = max(i__1,i__2);
r__1 = (real) llwork / (real) nb;
llwork = sceil_(&r__1);
if (nt > nb) {
lbwork = k - nt;
/* Optimal workspace for dlarfb = MAX(1,N)*NT */
lwkopt = (lbwork + llwork) * nb;
work[1] = (doublereal) (lwkopt + nt * nt);
} else {
r__1 = (real) k / (real) nb;
lbwork = sceil_(&r__1) * nb;
lwkopt = (lbwork + llwork - nb) * nb;
work[1] = (doublereal) lwkopt;
}
/* Test the input arguments */
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQRF", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (k == 0) {
work[1] = 1.;
return 0;
}
if (nb > 1 && nb < k) {
if (nx < k) {
/* Determine if workspace is large enough for blocked code. */
if (nt <= nb) {
iws = (lbwork + llwork - nb) * nb;
} else {
iws = (lbwork + llwork) * nb + nt * nt;
}
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
if (nt <= nb) {
nb = *lwork / (llwork + (lbwork - nb));
} else {
nb = (*lwork - nt * nt) / (lbwork + llwork);
}
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
c_n1);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Update the current column using old T's */
i__3 = i__ - nb;
i__4 = nb;
for (j = 1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* Apply H' to A(J:M,I:I+IB-1) from the left */
i__5 = *m - j + 1;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__5, &
ib, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt * nt
+ 1], &ib);
/* L20: */
}
/* Compute the QR factorization of the current block */
/* A(I:M,I:I+IB-1) */
i__4 = *m - i__ + 1;
dgeqr2_(&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
lbwork * nb + nt * nt + 1], &iinfo);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = *m - i__ + 1;
dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[i__], &lbwork);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
if (i__ != 1) {
i__2 = i__ - nb;
i__1 = nb;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Apply H' to A(J:M,I:K) from the left */
i__4 = *m - j + 1;
i__3 = k - i__ + 1;
i__5 = k - i__ + 1;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
i__3, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork,
&a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt *
nt + 1], &i__5);
/* L30: */
}
i__1 = *m - i__ + 1;
i__2 = k - i__ + 1;
dgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[lbwork * nb + nt * nt + 1], &iinfo);
} else {
/* Use unblocked code to factor the last or only block. */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
dgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo);
}
}
/* Apply update to the column M+1:N when N > M */
if (*m < *n && i__ != 1) {
/* Form the last triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
if (nt <= nb) {
i__1 = *m - i__ + 1;
i__2 = k - i__ + 1;
dlarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[i__], &lbwork);
} else {
i__1 = *m - i__ + 1;
i__2 = k - i__ + 1;
dlarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[lbwork * nb + 1], &nt);
}
/* Apply H' to A(1:M,M+1:N) from the left */
i__1 = k - nx;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__4 = k - j + 1;
ib = min(i__4,nb);
i__4 = *m - j + 1;
i__3 = *n - *m;
i__5 = *n - *m;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
i__3, &ib, &a[j + j * a_dim1], lda, &work[j], &lbwork, &a[
j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt * nt
+ 1], &i__5);
/* L40: */
}
if (nt <= nb) {
i__2 = *m - j + 1;
i__1 = *n - *m;
i__4 = k - j + 1;
i__3 = *n - *m;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
i__1, &i__4, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
a[j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt *
nt + 1], &i__3);
} else {
i__2 = *m - j + 1;
i__1 = *n - *m;
i__4 = k - j + 1;
i__3 = *n - *m;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
i__1, &i__4, &a[j + j * a_dim1], lda, &work[lbwork * nb +
1], &nt, &a[j + (*m + 1) * a_dim1], lda, &work[lbwork *
nb + nt * nt + 1], &i__3);
}
}
work[1] = (doublereal) iws;
return 0;
/* End of DGEQRF */
} /* dgeqrf_ */
/* Subroutine */ int dchktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublereal *a, doublereal *copya, doublereal *s, doublereal *copys,
doublereal *tau, doublereal *work, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, im, in, lda;
doublereal eps;
integer mode, info;
char path[3];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], imode;
extern doublereal dqrt12_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer mnmin;
extern doublereal drzt01_(integer *, integer *, doublereal *, doublereal *
, integer *, doublereal *, doublereal *, integer *), drzt02_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dtzt01_(integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dtzt02_(integer *, integer *, doublereal *, integer *
, doublereal *, doublereal *, integer *);
integer nerrs, lwork;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *), dlatms_(integer *,
integer *, char *, integer *, char *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, char *,
doublereal *, integer *, doublereal *, integer *), derrtz_(char *, integer *), dtzrqf_(integer *,
integer *, doublereal *, integer *, doublereal *, integer *);
doublereal result[6];
extern /* Subroutine */ int dtzrzf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKTZ tests DTZRQF and STZRZF. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (MMAX*NMAX + 4*NMAX + MMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
derrtz_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL for which M .LE. N. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = n * n + (m << 2) + n, i__3 = max(i__3,i__4),
i__4 = m * n + (mnmin << 1) + (n << 2);
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
if (! dotype[imode]) {
goto L50;
}
/* Do for each type of singular value distribution. */
/* 0: zero matrix */
/* 1: one small singular value */
/* 2: exponential distribution */
mode = imode - 1;
/* Test DTZRQF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
dlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L20: */
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
dgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
dlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
dlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call DTZRQF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "DTZRQF", (ftnlen)32, (ftnlen)6);
dtzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = dqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[1] = dtzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = dtzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test DTZRZF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
dlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
dgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
dlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
dlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call DTZRZF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "DTZRZF", (ftnlen)32, (ftnlen)6);
dtzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = dqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[4] = drzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = drzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 6;
L50:
;
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if DCHKTZ */
return 0;
} /* dchktz_ */
/*< SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) >*/
/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), dlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/*< INTEGER INFO, LDA, LWORK, M, N >*/
/* .. */
/* .. Array Arguments .. */
/*< DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DGEQRF computes a QR factorization of a real M-by-N matrix A: */
/* A = Q * R. */
/* 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/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 R (R is */
/* upper triangular if m >= n); the elements below the diagonal, */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of min(m,n) elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* 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). */
/* For optimum performance LWORK >= N*NB, where NB is */
/* the optimal blocksize. */
/* 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 */
/* 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 - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
/* and tau in TAU(i). */
/* ===================================================================== */
/* .. Local Scalars .. */
/*< LOGICAL LQUERY >*/
/*< >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC MAX, MIN >*/
/* .. */
/* .. External Functions .. */
/*< INTEGER ILAENV >*/
/*< EXTERNAL ILAENV >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/*< INFO = 0 >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/*< NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) >*/
nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1);
/*< LWKOPT = N*NB >*/
lwkopt = *n * nb;
/*< WORK( 1 ) = LWKOPT >*/
work[1] = (doublereal) lwkopt;
/*< LQUERY = ( LWORK.EQ.-1 ) >*/
lquery = *lwork == -1;
/*< IF( M.LT.0 ) THEN >*/
if (*m < 0) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( LDA.LT.MAX( 1, M ) ) THEN >*/
} else if (*lda < max(1,*m)) {
/*< INFO = -4 >*/
*info = -4;
/*< ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN >*/
} else if (*lwork < max(1,*n) && ! lquery) {
/*< INFO = -7 >*/
*info = -7;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DGEQRF', -INFO ) >*/
i__1 = -(*info);
xerbla_("DGEQRF", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< ELSE IF( LQUERY ) THEN >*/
} else if (lquery) {
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible */
/*< K = MIN( M, N ) >*/
k = min(*m,*n);
/*< IF( K.EQ.0 ) THEN >*/
if (k == 0) {
/*< WORK( 1 ) = 1 >*/
work[1] = 1.;
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< NBMIN = 2 >*/
nbmin = 2;
/*< NX = 0 >*/
nx = 0;
/*< IWS = N >*/
iws = *n;
/*< IF( NB.GT.1 .AND. NB.LT.K ) THEN >*/
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code. */
/*< NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) >*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
/*< IF( NX.LT.K ) THEN >*/
if (nx < k) {
/* Determine if workspace is large enough for blocked code. */
/*< LDWORK = N >*/
ldwork = *n;
/*< IWS = LDWORK*NB >*/
iws = ldwork * nb;
/*< IF( LWORK.LT.IWS ) THEN >*/
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
/*< NB = LWORK / LDWORK >*/
nb = *lwork / ldwork;
/*< >*/
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN >*/
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
/*< DO 10 I = 1, K - NX, NB >*/
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/*< IB = MIN( K-I+1, NB ) >*/
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the QR factorization of the current block */
/* A(i:m,i:i+ib-1) */
/*< >*/
i__3 = *m - i__ + 1;
dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
/*< IF( I+IB.LE.N ) THEN >*/
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
/*< >*/
i__3 = *m - i__ + 1;
dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7,
(ftnlen)10);
/* Apply H' to A(i:m,i+ib:n) from the left */
/*< >*/
i__3 = *m - i__ + 1;
i__4 = *n - i__ - ib + 1;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib
+ 1], &ldwork, (ftnlen)4, (ftnlen)9, (ftnlen)7, (
ftnlen)10);
/*< END IF >*/
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< ELSE >*/
} else {
/*< I = 1 >*/
i__ = 1;
/*< END IF >*/
}
/* Use unblocked code to factor the last or only block. */
/*< >*/
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
/*< WORK( 1 ) = IWS >*/
work[1] = (doublereal) iws;
/*< RETURN >*/
return 0;
/* End of DGEQRF */
/*< END >*/
} /* dgeqrf_ */
/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer *
lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, ma, mn;
static doublereal aii;
static integer pvt;
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal temp2;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen);
static integer itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dgeqr2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
dorm2r_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen), dlarfg_(integer *,
doublereal *, doublereal *, integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- LAPACK test routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine DGEQP3. */
/* DGEQPF computes a QR factorization with column pivoting of a */
/* real M-by-N matrix A: A*P = Q*R. */
/* 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/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of the array contains the */
/* min(M,N)-by-N upper triangular matrix R; the elements */
/* below the diagonal, together with the array TAU, */
/* represent the orthogonal matrix Q as a product of */
/* min(m,n) elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -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(n) */
/* Each H(i) has the form */
/* H = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
/* The matrix P is represented in jpvt as follows: If */
/* jpvt(j) = i */
/* then the jth column of P is the ith canonical unit vector. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQPF", &i__1, (ftnlen)6);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (jpvt[i__] != 0) {
if (i__ != itemp) {
dswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
&c__1);
jpvt[i__] = jpvt[itemp];
jpvt[itemp] = i__;
} else {
jpvt[i__] = i__;
}
++itemp;
} else {
jpvt[i__] = i__;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
dgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
dorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, &
tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info, (
ftnlen)4, (ftnlen)9);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of */
/* work store the exact column norms. */
i__1 = *n;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
i__2 = *m - itemp;
work[i__] = dnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
work[*n + i__] = work[i__];
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + idamax_(&i__2, &work[i__], &c__1);
if (pvt != i__) {
dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
work[pvt] = work[i__];
work[*n + pvt] = work[*n + i__];
}
/* Generate elementary reflector H(i) */
if (i__ < *m) {
i__2 = *m - i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
dlarfg_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], &
c__1, &tau[*m]);
}
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dlarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(*
n << 1) + 1], (ftnlen)4);
a[i__ + i__ * a_dim1] = aii;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (work[j] != 0.) {
/* Computing 2nd power */
d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / work[j];
temp = 1. - d__2 * d__2;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = work[j] / work[*n + j];
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i__ > 0) {
i__3 = *m - i__;
work[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1],
&c__1);
work[*n + j] = work[j];
} else {
work[j] = 0.;
work[*n + j] = 0.;
}
} else {
work[j] *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of DGEQPF */
} /* dgeqpf_ */
