/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *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 zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer ldwork;
extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer 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 */
/* ======= */
/* ZGEQRF computes a QR factorization of a complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace/output) COMPLEX*16 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 complex scalar, and v is a complex 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, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
lwkopt = *n * nb;
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
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_("ZGEQRF", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
if (k == 0) {
work[1].r = 1., work[1].i = 0.;
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, "ZGEQRF", " ", 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, "ZGEQRF", " ", 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;
zgeqr2_(&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;
zlarft_("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;
zlarfb_("Left", "Conjugate 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;
zgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZGEQRF */
} /* zgeqrf_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
integer i__, j, ma, mn;
doublecomplex aii;
integer pvt;
doublereal temp, temp2, tol3z;
integer itemp;
/* -- LAPACK deprecated driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZGEQP3. */
/* ZGEQPF computes a QR factorization with column pivoting of a */
/* complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 complex scalar, and v is a complex 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. */
/* Partial column norm updating strategy modified by */
/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
/* University of Zagreb, Croatia. */
/* June 2006. */
/* For more details see LAPACK Working Note 176. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--work;
--rwork;
/* 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_("ZGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
tol3z = sqrt(dlamch_("Epsilon"));
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (jpvt[i__] != 0) {
if (i__ != itemp) {
zswap_(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__;
}
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
, lda, &tau[1], &a[(ma + 1) * a_dim1 + 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__ <= i__1; ++i__) {
i__2 = *m - itemp;
rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
rwork[*n + i__] = rwork[i__];
}
/* 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, &rwork[i__], &c__1);
if (pvt != i__) {
zswap_(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;
rwork[pvt] = rwork[i__];
rwork[*n + pvt] = rwork[*n + i__];
}
/* Generate elementary reflector H(i) */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfp_(&i__2, &aii, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (rwork[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = z_abs(&a[i__ + j * a_dim1]) / rwork[j];
/* Computing MAX */
d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
temp = max(d__1,d__2);
/* Computing 2nd power */
d__1 = rwork[j] / rwork[*n + j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
if (*m - i__ > 0) {
i__3 = *m - i__;
rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
, &c__1);
rwork[*n + j] = rwork[j];
} else {
rwork[j] = 0.;
rwork[*n + j] = 0.;
}
} else {
rwork[j] *= sqrt(temp);
}
}
}
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
doublereal zqrt14_(char *trans, integer *m, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
doublecomplex *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;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer info;
static doublereal anrm;
static logical tpsd;
static doublereal xnrm;
static integer i__, j;
extern logical lsame_(char *, char *);
static doublereal rwork[1];
extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *);
static integer ldwork;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal err;
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZQRT14 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 = 'C') 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
= 'C': Conjugate transpose, check for X in 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) COMPLEX*16 array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
If TRANS = 'N', the N-by-NRHS matrix X.
IF TRANS = 'C', the M-by-NRHS matrix X.
LDX (input) INTEGER
The leading dimension of the array X.
WORK (workspace) COMPLEX*16 array dimension (LWORK)
LWORK (input) INTEGER
length of workspace array required
If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);
if TRANS = 'C', LWORK >= (N+NRHS)*(M+2).
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
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_("ZQRT14", &c__10);
return ret_val;
} else if (*n <= 0 || *nrhs <= 0) {
return ret_val;
}
} else if (lsame_(trans, "C")) {
ldwork = *m;
tpsd = TRUE_;
if (*lwork < (*n + *nrhs) * (*m + 2)) {
xerbla_("ZQRT14", &c__10);
return ret_val;
} else if (*m <= 0 || *nrhs <= 0) {
return ret_val;
}
} else {
xerbla_("ZQRT14", &c__1);
return ret_val;
}
/* Copy and scale A */
zlacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
anrm = zlange_("M", m, n, &work[1], &ldwork, rwork);
if (anrm != 0.) {
zlascl_("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 */
zlacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
ldwork);
xnrm = zlange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
if (xnrm != 0.) {
zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
ldwork + 1], &ldwork, &info);
}
i__1 = *n + *nrhs;
anrm = zlange_("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;
zgeqr2_(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__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * *m]);
err = max(d__1,d__2);
/* 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) {
i__3 = *m + j + (i__ - 1) * ldwork;
d_cnjg(&z__1, &x_ref(i__, j));
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
xnrm = zlange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
;
if (xnrm != 0.) {
zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
&ldwork, &info);
}
/* Compute LQ factorization of work */
zgelq2_(&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__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * ldwork]);
err = max(d__1,d__2);
/* L50: */
}
/* L60: */
}
}
/* Computing MAX */
i__1 = max(*m,*n);
ret_val = err / ((doublereal) max(i__1,*nrhs) * dlamch_("Epsilon"));
return ret_val;
/* End of ZQRT14 */
} /* zqrt14_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, ma, mn;
static doublecomplex aii;
static integer pvt;
static doublereal temp, temp2;
static integer itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZGEQP3. */
/* ZGEQPF computes a QR factorization with column pivoting of a */
/* complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 complex scalar, and v is a complex 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;
--rwork;
/* 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_("ZGEQPF", &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) {
zswap_(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);
zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
, lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1],
info, (ftnlen)4, (ftnlen)19);
}
}
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;
rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
rwork[*n + i__] = rwork[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, &rwork[i__], &c__1);
if (pvt != i__) {
zswap_(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;
rwork[pvt] = rwork[i__];
rwork[*n + pvt] = rwork[*n + i__];
}
/* Generate elementary reflector H(i) */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &aii, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (rwork[j] != 0.) {
/* Computing 2nd power */
d__1 = z_abs(&a[i__ + j * a_dim1]) / rwork[j];
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = rwork[j] / rwork[*n + j];
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i__ > 0) {
i__3 = *m - i__;
rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
, &c__1);
rwork[*n + j] = rwork[j];
} else {
rwork[j] = 0.;
rwork[*n + j] = 0.;
}
} else {
rwork[j] *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
/* Subroutine */ int zchktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
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 */
static integer mode, info;
static char path[3];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n, nfail, iseed[4], imode, mnmin, nerrs, lwork;
extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
, doublereal *, doublecomplex *, integer *, doublereal *),
zrzt01_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zrzt02_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt01_(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt02_(integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer im, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal result[6];
extern /* Subroutine */ int zerrtz_(char *, integer *), ztzrqf_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztzrzf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
;
static integer lda;
static doublereal eps;
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZCHKTZ tests ZTZRQF and ZTZRZF.
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) COMPLEX*16 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) COMPLEX*16 array, dimension (MMAX*NMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
TAU (workspace) COMPLEX*16 array, dimension (MMAX)
WORK (workspace) COMPLEX*16 array, dimension
(MMAX*NMAX + 4*NMAX + MMAX)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
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) {
zerrtz_(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;
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
/* Do for each type of singular value distribution.
0: zero matrix
1: one small singular value
2: exponential distribution */
mode = imode - 1;
/* Test ZTZRQF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("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;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRQF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)6, (ftnlen)6);
ztzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[1] = ztzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = ztzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test ZTZRZF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("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;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRZF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)6, (ftnlen)6);
ztzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[4] = zrzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = zrzt02_(&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 ZCHKTZ */
return 0;
} /* zchktz_ */
/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex
*b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k,
integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer
*ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal *
rwork, doublecomplex *tau, doublecomplex *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
=======
ZGGSVP computes unitary 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
conjugate transpose of Z.
This decomposition is the preprocessing step for computing the
Generalized Singular Value Decomposition (GSVD), see subroutine
ZGGSVD.
Arguments
=========
JOBU (input) CHARACTER*1
= 'U': Unitary matrix U is computed;
= 'N': U is not computed.
JOBV (input) CHARACTER*1
= 'V': Unitary matrix V is computed;
= 'N': V is not computed.
JOBQ (input) CHARACTER*1
= 'Q': Unitary 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) COMPLEX*16 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) COMPLEX*16 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 section.
K + L = effective numerical rank of (A',B')'.
U (output) COMPLEX*16 array, dimension (LDU,M)
If JOBU = 'U', U contains the unitary 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) COMPLEX*16 array, dimension (LDV,M)
If JOBV = 'V', V contains the unitary 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) COMPLEX*16 array, dimension (LDQ,N)
If JOBQ = 'Q', Q contains the unitary 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)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
TAU (workspace) COMPLEX*16 array, dimension (N)
WORK (workspace) COMPLEX*16 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 ZGEQPF 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 doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
/* 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, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
static logical wantq, wantu, wantv;
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zgerq2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zung2r_(integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zunm2r_(char *, char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zunmr2_(char *, char *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(
char *, integer *), zgeqpf_(integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static logical forwrd;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlapmt_(logical *, integer *, integer *, doublecomplex *,
integer *, integer *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
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;
--rwork;
--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_("ZGGSVP", &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: */
}
zgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1],
info);
/* Update A := A*P */
zlapmt_(&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__) {
i__2 = b_subscr(i__, i__);
if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__, i__)),
abs(d__2)) > *tolb) {
++(*l);
}
/* L20: */
}
if (wantv) {
/* Copy the details of V, and form V. */
zlaset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv);
if (*p > 1) {
i__1 = *p - 1;
zlacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv);
}
i__1 = min(*p,*n);
zung2r_(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__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
if (*p > *l) {
i__1 = *p - *l;
zlaset_("Full", &i__1, n, &c_b1, &c_b1, &b_ref(*l + 1, 1), ldb);
}
if (wantq) {
/* Set Q = I and Update Q := Q*P */
zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
zlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
}
if (*p >= *l && *n != *l) {
/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */
zgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z' */
zunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, &
tau[1], &a[a_offset], lda, &work[1], info);
if (wantq) {
/* Update Q := Q*Z' */
zunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset],
ldb, &tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up B */
i__1 = *n - *l;
zlaset_("Full", l, &i__1, &c_b1, &c_b1, &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__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 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;
zgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[
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__) {
i__2 = a_subscr(i__, i__);
if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, i__)),
abs(d__2)) > *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);
zunm2r_("Left", "Conjugate 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 */
zlaset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu);
if (*m > 1) {
i__1 = *m - 1;
i__2 = *n - *l;
zlacpy_("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);
zung2r_(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;
zlapmt_(&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__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0., a[i__3].i = 0.;
/* L90: */
}
/* L100: */
}
if (*m > *k) {
i__1 = *m - *k;
i__2 = *n - *l;
zlaset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a_ref(*k + 1, 1), lda);
}
if (*n - *l > *k) {
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
zgerq2_(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;
zunmr2_("Right", "Conjugate 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;
zlaset_("Full", k, &i__1, &c_b1, &c_b1, &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__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0., a[i__3].i = 0.;
/* L110: */
}
/* L120: */
}
}
if (*m > *k) {
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
zgeqr2_(&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);
zunm2r_("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__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0., a[i__3].i = 0.;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of ZGGSVP */
} /* zggsvp_ */
/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *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 zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer lbwork;
extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer 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 */
/* ======= */
/* ZGEQRF 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) COMPLEX*16 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) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace/output) COMPLEX*16 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, 'ZGEQRF', ' ', 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, "ZGEQRF", " ", 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, "ZGEQRF", " ", 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;
i__1 = lwkopt + nt * nt;
work[1].r = (doublereal) i__1, work[1].i = 0.;
} else {
r__1 = (real) k / (real) nb;
lbwork = sceil_(&r__1) * nb;
lwkopt = (lbwork + llwork - nb) * nb;
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
}
/* 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_("ZGEQRF", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (k == 0) {
work[1].r = 1., work[1].i = 0.;
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, "ZGEQRF", " ", 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;
zlarfb_("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;
zgeqr2_(&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;
zlarft_("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;
zlarfb_("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;
zgeqr2_(&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;
zgeqr2_(&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;
zlarft_("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;
zlarft_("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;
zlarfb_("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;
zlarfb_("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;
zlarfb_("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].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZGEQRF */
} /* zgeqrf_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* -- LAPACK auxiliary 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
=======
ZGEQPF computes a QR factorization with column pivoting of a
complex 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) COMPLEX*16 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) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
WORK (workspace) COMPLEX*16 array, dimension (N)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 complex scalar, and v is a complex 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;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static doublereal temp, temp2;
static integer i, j, itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer ma, mn;
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static doublecomplex aii;
static integer pvt;
#define JPVT(I) jpvt[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(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_("ZGEQPF", &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) {
zswap_(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);
zgeqr2_(m, &ma, &A(1,1), lda, &TAU(1), &WORK(1), info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate 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;
RWORK(i) = dznrm2_(&i__2, &A(itemp+1,i), &c__1);
RWORK(*n + i) = RWORK(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, &RWORK(i), &c__1);
if (pvt != i) {
zswap_(m, &A(1,pvt), &c__1, &A(1,i), &
c__1);
itemp = JPVT(pvt);
JPVT(pvt) = JPVT(i);
JPVT(i) = itemp;
RWORK(pvt) = RWORK(i);
RWORK(*n + pvt) = RWORK(*n + i);
}
/* Generate elementary reflector H(i) */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = *m - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &aii, &A(min(i+1,*m),i), &c__1, &TAU(i)
);
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
if (i < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
i__2 = *m - i + 1;
i__3 = *n - i;
d_cnjg(&z__1, &TAU(i));
zlarf_("Left", &i__2, &i__3, &A(i,i), &c__1, &z__1,
&A(i,i+1), lda, &WORK(1));
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
if (RWORK(j) != 0.) {
/* Computing 2nd power */
d__1 = z_abs(&A(i,j)) / RWORK(j);
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = RWORK(j) / RWORK(*n + j);
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i > 0) {
i__3 = *m - i;
RWORK(j) = dznrm2_(&i__3, &A(i+1,j),
&c__1);
RWORK(*n + j) = RWORK(j);
} else {
RWORK(j) = 0.;
RWORK(*n + j) = 0.;
}
} else {
RWORK(j) *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int zneupd_(logical *rvec, char *howmny, logical *select,
doublecomplex *d__, doublecomplex *z__, integer *ldz, doublecomplex *
sigma, doublecomplex *workev, char *bmat, integer *n, char *which,
integer *nev, doublereal *tol, doublecomplex *resid, integer *ncv,
doublecomplex *v, integer *ldv, integer *iparam, integer *ipntr,
doublecomplex *workd, doublecomplex *workl, integer *lworkl,
doublereal *rwork, 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, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer j, k, ih, jj, iq, np;
static doublecomplex vl[1];
static integer wr, ibd, ldh, ldq;
static doublereal sep;
static integer irz, mode;
static doublereal eps23;
static integer ierr;
static doublecomplex temp;
static integer iwev;
static char type__[6];
static integer ritz, iheig, ihbds;
static doublereal conds;
static logical reord;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer nconv;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal rtemp;
static doublecomplex rnorm;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ivout_(integer *, integer
*, integer *, integer *, char *, ftnlen), ztrmm_(char *, char *,
char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen), zmout_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(
integer *, integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *, ftnlen);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen);
static integer bounds, invsub, iuptri, msglvl, outncv, numcnv, ishift;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlahqr_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *), zngets_(integer *, char *
, integer *, integer *, doublecomplex *, doublecomplex *, ftnlen),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, ftnlen), ztrsen_(
char *, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *, integer *,
ftnlen, ftnlen), ztrevc_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublecomplex *,
doublereal *, integer *, ftnlen, ftnlen), zdscal_(integer *,
doublereal *, doublecomplex *, integer *);
/* %----------------------------------------------------% */
/* | 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 | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
--workd;
--resid;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--rwork;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mceupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
eps23 = pow_dd(&eps23, &c_b5);
/* %-------------------------------% */
/* | Quick return | */
/* | Check for incompatible input | */
/* %-------------------------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + (*ncv << 2)) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
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 {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, WORKEV, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | */
/* | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by ZNEUPD. | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | */
/* | Ritz values. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | error bounds of | */
/* | the Ritz values | */
/* | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | */
/* | triangular matrix | */
/* | for H. | */
/* | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | */
/* | associated matrix | */
/* | representation of | */
/* | the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritz = ipntr[6];
iq = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheig = bounds + ldh;
ihbds = iheig + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheig;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wr = 1;
iwev = wr + *ncv;
/* %-----------------------------------------% */
/* | irz points to the Ritz values computed | */
/* | by _neigh before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irz = ipntr[14] + *ncv * *ncv;
ibd = irz + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
i__1 = ih + 2;
rnorm.r = workl[i__1].r, rnorm.i = workl[i__1].i;
i__1 = ih + 2;
workl[i__1].r = 0., workl[i__1].i = 0.;
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neupd: "
"Ritz values passed in from _NAUPD.", (ftnlen)42);
zvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (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) {
i__2 = bounds + j - 1;
workl[i__2].r = (doublereal) j, workl[i__2].i = 0.;
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(ibd) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
zngets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], (
ftnlen)2);
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neu"
"pd: Ritz values after calling _NGETS.", (ftnlen)41);
zvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
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 */
i__2 = irz + *ncv - j;
d__3 = workl[i__2].r;
d__4 = d_imag(&workl[irz + *ncv - j]);
d__1 = eps23, d__2 = dlapy2_(&d__3, &d__4);
rtemp = max(d__1,d__2);
i__2 = bounds + *ncv - j;
jj = (integer) workl[i__2].r;
i__2 = ibd + jj - 1;
d__1 = workl[i__2].r;
d__2 = d_imag(&workl[ibd + jj - 1]);
if (numcnv < nconv && dlapy2_(&d__1, &d__2) <= *tol * rtemp) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-------------------------------------------------------% */
/* | Call LAPACK routine zlahqr to compute the Schur form | */
/* | of the upper Hessenberg matrix returned by ZNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-------------------------------------------------------% */
i__1 = ldh * *ncv;
zcopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
zlaset_("All", ncv, ncv, &c_b2, &c_b1, &workl[invsub], &ldq, (ftnlen)
3);
zlahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheig], &c__1, ncv, &workl[invsub], &ldq, &ierr);
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H", (ftnlen)24);
zvout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper triangular matrix "
, (ftnlen)36);
}
}
if (reord) {
/* %-----------------------------------------------% */
/* | Reorder the computed upper triangular matrix. | */
/* %-----------------------------------------------% */
ztrsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheig], &nconv, &conds, &sep,
&workev[1], ncv, &ierr, (ftnlen)4, (ftnlen)1);
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H--reordered", (ftnlen)35);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Triangular matrix after"
" re-ordering", (ftnlen)43);
}
}
}
/* %---------------------------------------------% */
/* | Copy the last row of the Schur basis matrix | */
/* | to workl(ihbds). This vector will be used | */
/* | to compute the Ritz estimates of converged | */
/* | Ritz values. | */
/* %---------------------------------------------% */
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %--------------------------------------------% */
/* | Place the computed eigenvalues of H into D | */
/* | if a spectral transformation was not used. | */
/* %--------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
zcopy_(&nconv, &workl[iheig], &c__1, &d__[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
zgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %--------------------------------------------------------% */
/* | * Postmultiply V by Q using zunm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheig). The first NCONV | */
/* | columns of V are now approximate Schur vectors | */
/* | associated with the upper triangular matrix of order | */
/* | NCONV in workl(iuptri). | */
/* %--------------------------------------------------------% */
zunm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
zlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | triangular form of workl(iuptri,ldq). | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones. | */
/* %---------------------------------------------------% */
i__2 = invsub + (j - 1) * ldq + j - 1;
if (workl[i__2].r < 0.) {
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + j - 1], &ldq);
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
ztrevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&rwork[1], &ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | ztrevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
rtemp = dznrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
rtemp = 1. / rtemp;
zdscal_(ncv, &rtemp, &workl[invsub + (j - 1) * ldq], &c__1);
/* %------------------------------------------% */
/* | Ritz estimates can be obtained by taking | */
/* | the inner product of the last row of the | */
/* | Schur basis of H with eigenvectors of T. | */
/* | Note that the eigenvector matrix of T is | */
/* | upper triangular, thus the length of the | */
/* | inner product can be set to j. | */
/* %------------------------------------------% */
i__2 = j;
zdotc_(&z__1, &j, &workl[ihbds], &c__1, &workl[invsub + (j -
1) * ldq], &c__1);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
/* L40: */
}
if (msglvl > 2) {
zcopy_(&nconv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds],
&c__1);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Last row of the eigenvector"
" matrix for T", (ftnlen)48);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
zcopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %----------------------------------------------% */
/* | The eigenvector matrix Q of T is triangular. | */
/* | Form Z*Q. | */
/* %----------------------------------------------% */
ztrmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b1, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %--------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed ZNAUPD into D. | */
/* %--------------------------------------------------% */
zcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
zcopy_(&nconv, &workl[ritz], &c__1, &workl[iheig], &c__1);
zcopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
i__2 = iheig + k - 1;
temp.r = workl[i__2].r, temp.i = workl[i__2].i;
i__2 = ihbds + k - 1;
z_div(&z__2, &workl[ihbds + k - 1], &temp);
z_div(&z__1, &z__2, &temp);
workl[i__2].r = z__1.r, workl[i__2].i = z__1.i;
/* L50: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = nconv;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
z_div(&z__2, &c_b1, &workl[iheig + k - 1]);
z__1.r = z__2.r + sigma->r, z__1.i = z__2.i + sigma->i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
/* L60: */
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: U"
"ntransformed Ritz values.", (ftnlen)34);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of the untransformed Ritz values.", (
ftnlen)56);
} else if (msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: C"
"onverged Ritz values.", (ftnlen)30);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 3. See reference 3. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
i__2 = iheig + j - 1;
if (workl[i__2].r != 0. || workl[i__2].i != 0.) {
i__2 = j;
z_div(&z__1, &workl[invsub + (j - 1) * ldq + *ncv - 1], &
workl[iheig + j - 1]);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
}
/* L100: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
zgeru_(n, &nconv, &c_b1, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of zneupd| */
/* %---------------% */
} /* zneupd_ */
/*< SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) >*/
/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *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 zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
integer ldwork;
extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, ftnlen, ftnlen);
integer lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/*< INTEGER INFO, LDA, LWORK, M, N >*/
/* .. */
/* .. Array Arguments .. */
/*< COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZGEQRF computes a QR factorization of a complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace/output) COMPLEX*16 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 complex scalar, and v is a complex 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 XERBLA, ZGEQR2, ZLARFB, ZLARFT >*/
/* .. */
/* .. 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, 'ZGEQRF', ' ', M, N, -1, -1 ) >*/
nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)
1);
/*< LWKOPT = N*NB >*/
lwkopt = *n * nb;
/*< WORK( 1 ) = LWKOPT >*/
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
/*< 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( 'ZGEQRF', -INFO ) >*/
i__1 = -(*info);
xerbla_("ZGEQRF", &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].r = 1., work[1].i = 0.;
/*< 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, 'ZGEQRF', ' ', M, N, -1, -1 ) ) >*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", 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, "ZGEQRF", " ", 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;
zgeqr2_(&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;
zlarft_("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;
zlarfb_("Left", "Conjugate 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)19, (
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;
zgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
/*< WORK( 1 ) = IWS >*/
work[1].r = (doublereal) iws, work[1].i = 0.;
/*< RETURN >*/
return 0;
/* End of ZGEQRF */
/*< END >*/
} /* zgeqrf_ */
/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZGEQRF computes a QR factorization of a complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace/output) COMPLEX*16 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.
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 complex scalar, and v is a complex 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).
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i, k, nbmin, iinfo;
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer ib, nb, nx;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer ldwork;
extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer iws;
#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;
} else if (*lwork < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQRF", &i__1);
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
if (k == 0) {
WORK(1).r = 1., WORK(1).i = 0.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
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, "ZGEQRF", " ", m, n, &c_n1, &c_n1, 6L,
1L);
nx = max(i__1,i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and
determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", m, n, &c_n1, &
c_n1, 6L, 1L);
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; nb < 0 ? i >= k-nx : i <= k-nx; i += 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;
zgeqr2_(&i__3, &ib, &A(i,i), lda, &TAU(i), &WORK(1), &
iinfo);
if (i + ib <= *n) {
/* Form the triangular factor of the block reflec
tor
H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *m - i + 1;
zlarft_("Forward", "Columnwise", &i__3, &ib, &A(i,i), 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;
zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise"
, &i__3, &i__4, &ib, &A(i,i), lda, &WORK(1)
, &ldwork, &A(i,i+ib), 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;
zgeqr2_(&i__2, &i__1, &A(i,i), lda, &TAU(i), &WORK(1), &
iinfo);
}
WORK(1).r = (doublereal) iws, WORK(1).i = 0.;
return 0;
/* End of ZGEQRF */
} /* zgeqrf_ */
/* Subroutine */ int zerrqr_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublecomplex a[4] /* was [2][2] */, b[2];
static integer i__, j;
static doublecomplex w[2], x[2], af[4] /* was [2][2] */;
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zung2r_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), zunm2r_(char *,
char *, integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
*), zgeqrf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
, zgeqrs_(integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), zungqr_(integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *), zunmqr_(char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
#define a_subscr(a_1,a_2) (a_2)*2 + a_1 - 3
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*2 + a_1 - 3
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZERRQR tests the error exits for the COMPLEX*16 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.
===================================================================== */
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__) {
i__1 = a_subscr(i__, j);
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = af_subscr(i__, j);
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
af[i__1].r = z__1.r, af[i__1].i = z__1.i;
/* L10: */
}
i__1 = j - 1;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = j - 1;
w[i__1].r = 0., w[i__1].i = 0.;
i__1 = j - 1;
x[i__1].r = 0., x[i__1].i = 0.;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for QR factorization
ZGEQRF */
s_copy(srnamc_1.srnamt, "ZGEQRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGEQR2 */
s_copy(srnamc_1.srnamt, "ZGEQR2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGEQRS */
s_copy(srnamc_1.srnamt, "ZGEQRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNGQR */
s_copy(srnamc_1.srnamt, "ZUNGQR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zungqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zungqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zungqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zungqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zungqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNG2R */
s_copy(srnamc_1.srnamt, "ZUNG2R", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zung2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zung2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zung2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zung2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zung2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zung2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNMQR */
s_copy(srnamc_1.srnamt, "ZUNMQR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zunmqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunmqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunmqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunmqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunmqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zunmqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zunmqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNM2R */
s_copy(srnamc_1.srnamt, "ZUNM2R", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zunm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("ZUNM2R", &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 ZERRQR */
} /* zerrqr_ */
