/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer
*nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt,
doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *
auxv, doublecomplex *f, integer *ldf)
{
/* System generated locals */
integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
integer i_dnnt(doublereal *);
/* Local variables */
integer j, k, rk;
doublecomplex akk;
integer pvt;
doublereal temp, temp2, tol3z;
integer itemp;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
extern integer idamax_(integer *, doublereal *, integer *);
integer lsticc;
extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
integer lastrk;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQPS computes a step of QR factorization with column pivoting */
/* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */
/* NB columns from A starting from the row OFFSET+1, and updates all */
/* of the matrix with Blas-3 xGEMM. */
/* In some cases, due to catastrophic cancellations, it cannot */
/* factorize NB columns. Hence, the actual number of factorized */
/* columns is returned in KB. */
/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* 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 */
/* OFFSET (input) INTEGER */
/* The number of rows of A that have been factorized in */
/* previous steps. */
/* NB (input) INTEGER */
/* The number of columns to factorize. */
/* KB (output) INTEGER */
/* The number of columns actually factorized. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
/* factor obtained and block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
/* been updated. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* JPVT(I) = K <==> Column K of the full matrix A has been */
/* permuted into position I in AP. */
/* TAU (output) COMPLEX*16 array, dimension (KB) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the exact column norms. */
/* AUXV (input/output) COMPLEX*16 array, dimension (NB) */
/* Auxiliar vector. */
/* F (input/output) COMPLEX*16 array, dimension (LDF,NB) */
/* Matrix F' = L*Y'*A. */
/* LDF (input) INTEGER */
/* The leading dimension of the array F. LDF >= max(1,N). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--auxv;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
/* Computing MIN */
i__1 = *m, i__2 = *n + *offset;
lastrk = min(i__1,i__2);
lsticc = 0;
k = 0;
tol3z = sqrt(dlamch_("Epsilon"));
/* Beginning of while loop. */
L10:
if (k < *nb && lsticc == 0) {
++k;
rk = *offset + k;
/* Determine ith pivot column and swap if necessary */
i__1 = *n - k + 1;
pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1);
if (pvt != k) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
zswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[k];
jpvt[k] = itemp;
vn1[pvt] = vn1[k];
vn2[pvt] = vn2[k];
}
/* Apply previous Householder reflectors to column K: */
/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
if (k > 1) {
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L20: */
}
i__1 = *m - rk + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1], lda,
&f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L30: */
}
}
/* Generate elementary reflector H(k). */
if (rk < *m) {
i__1 = *m - rk + 1;
zlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
c__1, &tau[k]);
} else {
zlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
tau[k]);
}
i__1 = rk + k * a_dim1;
akk.r = a[i__1].r, akk.i = a[i__1].i;
i__1 = rk + k * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
/* Compute Kth column of F: */
/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
if (k < *n) {
i__1 = *m - rk + 1;
i__2 = *n - k;
zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k +
1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
k + 1 + k * f_dim1], &c__1);
}
/* Padding F(1:K,K) with zeros. */
i__1 = k;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * f_dim1;
f[i__2].r = 0., f[i__2].i = 0.;
/* L40: */
}
/* Incremental updating of F: */
/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
/* *A(RK:M,K). */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
i__3 = k;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1]
, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);
i__1 = k - 1;
zgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
}
/* Update the current row of A: */
/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
z__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
c_b2, &a[rk + (k + 1) * a_dim1], lda);
}
/* Update partial column norms. */
if (rk < lastrk) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
if (vn1[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = z_abs(&a[rk + j * a_dim1]) / vn1[j];
/* Computing MAX */
d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
temp = max(d__1,d__2);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
vn2[j] = (doublereal) lsticc;
lsticc = j;
} else {
vn1[j] *= sqrt(temp);
}
}
/* L50: */
}
}
i__1 = rk + k * a_dim1;
a[i__1].r = akk.r, a[i__1].i = akk.i;
/* End of while loop. */
goto L10;
}
*kb = k;
rk = *offset + *kb;
/* Apply the block reflector to the rest of the matrix: */
/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
/* Computing MIN */
i__1 = *n, i__2 = *m - *offset;
if (*kb < min(i__1,i__2)) {
i__1 = *m - rk;
i__2 = *n - *kb;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1,
&a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
a[rk + 1 + (*kb + 1) * a_dim1], lda);
}
/* Recomputation of difficult columns. */
L60:
if (lsticc > 0) {
itemp = i_dnnt(&vn2[lsticc]);
i__1 = *m - rk;
vn1[lsticc] = dznrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
/* SNRM2 does not fail on vectors with norm below the value of */
/* SQRT(DLAMCH('S')) */
vn2[lsticc] = vn1[lsticc];
lsticc = itemp;
goto L60;
}
return 0;
/* End of ZLAQPS */
} /* zlaqps_ */
/* 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_ */
/* Subroutine */ int zlaqp2_(integer *m, integer *n, integer *offset,
doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau,
doublereal *vn1, doublereal *vn2, doublecomplex *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j, mn;
doublecomplex aii;
integer pvt;
doublereal temp, temp2, tol3z;
integer offpi, itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQP2 computes a QR factorization with column pivoting of */
/* the block A(OFFSET+1:M,1:N). */
/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* 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. */
/* OFFSET (input) INTEGER */
/* The number of rows of the matrix A that must be pivoted */
/* but no factorized. OFFSET >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
/* the triangular factor obtained; the elements in block */
/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
/* array TAU, represent the orthogonal matrix Q as a product of */
/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* 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. */
/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the exact column norms. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *m - *offset;
mn = min(i__1,*n);
tol3z = sqrt(dlamch_("Epsilon"));
/* Compute factorization. */
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + idamax_(&i__2, &vn1[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;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m) {
i__2 = *m - offpi + 1;
zlarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
zlarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
c__1, &tau[i__]);
}
if (i__ < *n) {
/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
i__2 = offpi + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = offpi + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
z__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = offpi + 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 (vn1[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
/* Computing 2nd power */
d__1 = z_abs(&a[offpi + j * a_dim1]) / vn1[j];
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
if (offpi < *m) {
i__3 = *m - offpi;
vn1[j] = dznrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
c__1);
vn2[j] = vn1[j];
} else {
vn1[j] = 0.;
vn2[j] = 0.;
}
} else {
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of ZLAQP2 */
} /* zlaqp2_ */
int zgerq2_(int *m, int *n, doublecomplex *a,
int *lda, doublecomplex *tau, doublecomplex *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
/* Local variables */
int i__, k;
doublecomplex alpha;
extern int zlarf_(char *, int *, int *,
doublecomplex *, int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *), xerbla_(char *, int *), zlacgv_(int *, doublecomplex *, int *), zlarfp_(
int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGERQ2 computes an RQ factorization of a complex m by n matrix A: */
/* A = R * Q. */
/* 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, if m <= n, the upper triangle of the subarray */
/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
/* contain the m by n upper trapezoidal matrix R; the remaining */
/* elements, with the array TAU, represent the unitary matrix */
/* Q as a product of elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (MIN(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (M) */
/* 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */
/* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic 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;
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_("ZGERQ2", &i__1);
return 0;
}
k = MIN(*m,*n);
for (i__ = k; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* A(m-k+i,1:n-k+i-1) */
i__1 = *n - k + i__;
zlacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *n - k + i__;
zlarfp_(&i__1, &alpha, &a[*m - k + i__ + a_dim1], lda, &tau[i__]);
/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *m - k + i__ - 1;
i__2 = *n - k + i__;
zlarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
i__], &a[a_offset], lda, &work[1]);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
i__1 = *n - k + i__ - 1;
zlacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
/* L10: */
}
return 0;
/* End of ZGERQ2 */
} /* zgerq2_ */
/* Subroutine */ int zgeql2_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
/* Local variables */
integer i__, k;
doublecomplex alpha;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZGEQL2 computes a QL factorization of a complex m by n matrix A: */
/* A = Q * L. */
/* 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, if m >= n, the lower triangle of the subarray */
/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
/* if m <= n, the elements on and below the (n-m)-th */
/* superdiagonal contain the m by n lower trapezoidal matrix L; */
/* the remaining elements, with the array TAU, represent the */
/* unitary matrix Q as a product of elementary reflectors */
/* (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (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(k) . . . H(2) H(1), 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQL2", &i__1);
return 0;
}
k = min(*m,*n);
for (i__ = k; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:m-k+i-1,n-k+i) */
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *m - k + i__;
zlarfp_(&i__1, &alpha, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &tau[
i__]);
/* Apply H(i)' to A(1:m-k+i,1:n-k+i-1) from the left */
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *m - k + i__;
i__2 = *n - k + i__ - 1;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
z__1, &a[a_offset], lda, &work[1]);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
}
return 0;
/* End of ZGEQL2 */
} /* zgeql2_ */
/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k, m1;
doublecomplex alpha;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *), zlarfp_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZTZRZF. */
/* ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
/* to upper triangular form by means of unitary transformations. */
/* The upper trapezoidal matrix A is factored as */
/* A = ( R 0 ) * Z, */
/* where Z is an N-by-N unitary matrix and R is an M-by-M upper */
/* triangular matrix. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= M. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the leading M-by-N upper trapezoidal part of the */
/* array A must contain the matrix to be factorized. */
/* On exit, the leading M-by-M upper triangular part of A */
/* contains the upper triangular matrix R, and elements M+1 to */
/* N of the first M rows of A, with the array TAU, represent the */
/* unitary matrix Z as a product of M elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), whose conjugate transpose is used to */
/* introduce zeros into the (m - k + 1)th row of A, is given in the form */
/* Z( k ) = ( I 0 ), */
/* ( 0 T( k ) ) */
/* where */
/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
/* ( 0 ) */
/* ( z( k ) ) */
/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
/* tau and z( k ) are chosen to annihilate the elements of the kth row */
/* of X. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A, such that the elements of z( k ) are */
/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTZRQF", &i__1);
return 0;
}
/* Perform the factorization. */
if (*m == 0) {
return 0;
}
if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L10: */
}
} else {
/* Computing MIN */
i__1 = *m + 1;
m1 = min(i__1,*n);
for (k = *m; k >= 1; --k) {
/* Use a Householder reflection to zero the kth row of A. */
/* First set up the reflection. */
i__1 = k + k * a_dim1;
d_cnjg(&z__1, &a[k + k * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = *n - *m;
zlacgv_(&i__1, &a[k + m1 * a_dim1], lda);
i__1 = k + k * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *n - *m + 1;
zlarfp_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]);
i__1 = k + k * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
i__1 = k;
d_cnjg(&z__1, &tau[k]);
tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
i__1 = k;
if ((tau[i__1].r != 0. || tau[i__1].i != 0.) && k > 1) {
/* We now perform the operation A := A*P( k )'. */
/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
/* where a( k ) consists of the first ( k - 1 ) elements of */
/* the kth column of A. Also let B denote the first */
/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
/* Form w = a( k ) + B*z( k ) in TAU. */
i__1 = k - 1;
i__2 = *n - *m;
zgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 +
1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], &
c__1);
/* Now form a( k ) := a( k ) - conjg(tau)*w */
/* and B := B - conjg(tau)*w*z( k )'. */
i__1 = k - 1;
d_cnjg(&z__2, &tau[k]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zaxpy_(&i__1, &z__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
c__1);
i__1 = k - 1;
i__2 = *n - *m;
d_cnjg(&z__2, &tau[k]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&i__1, &i__2, &z__1, &tau[1], &c__1, &a[k + m1 *
a_dim1], lda, &a[m1 * a_dim1 + 1], lda);
}
/* L20: */
}
}
return 0;
/* End of ZTZRQF */
} /* ztzrqf_ */