/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
integer k;
doublecomplex ct;
doublereal akk, bkk;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZHEGS2 reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by ZPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) COMPLEX*16 array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by ZPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
i__2 = *n - k;
zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__2, &z__1, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
ztrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
a_dim1], lda);
i__2 = *n - k;
zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
}
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__2, &z__1, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
ztrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
ztrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
a[i__2].r = d__1, a[i__2].i = 0.;
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
zlacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k - 1;
ztrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a[k + a_dim1], lda);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zlacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
, ldb, &a[a_offset], lda);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
zlacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &a[k + a_dim1], lda);
i__2 = k - 1;
zlacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
a[i__2].r = d__1, a[i__2].i = 0.;
}
}
}
return 0;
/* End of ZHEGS2 */
} /* zhegs2_ */
int zpbtf2_(char *uplo, int *n, int *kd,
doublecomplex *ab, int *ldab, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3;
double d__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int j, kn;
double ajj;
int kld;
extern int zher_(char *, int *, double *,
doublecomplex *, int *, doublecomplex *, int *);
extern int lsame_(char *, char *);
int upper;
extern int xerbla_(char *, int *), zdscal_(
int *, double *, doublecomplex *, int *), zlacgv_(
int *, doublecomplex *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPBTF2 computes the Cholesky factorization of a complex Hermitian */
/* positive definite band matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix, U' is the conjugate transpose */
/* of U, and L is lower triangular. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd). */
/* On exit, if INFO = 0, the triangular factor U or L from the */
/* Cholesky factorization A = U'*U or A = L*L' of the band */
/* matrix A, in the same storage format as A. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* N = 6, KD = 2, and UPLO = 'U': */
/* On entry: On exit: */
/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* Similarly, if UPLO = 'L' the format of A is as follows: */
/* On entry: On exit: */
/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
/* Array elements marked * are not used by the routine. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = MAX(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of row J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
zher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of column J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab[j * ab_dim1 + 2], &c__1);
zher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of ZPBTF2 */
} /* zpbtf2_ */
/* Subroutine */ int zlarz_(char *side, integer *m, integer *n, integer *l,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c__, integer *ldc, doublecomplex *work)
{
/* System generated locals */
integer c_dim1, c_offset;
doublecomplex z__1;
/* Local variables */
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLARZ applies a complex elementary reflector H to a complex */
/* M-by-N matrix C, from either the left or the right. H is represented */
/* in the form */
/* H = I - tau * v * v' */
/* where tau is a complex scalar and v is a complex vector. */
/* If tau = 0, then H is taken to be the unit matrix. */
/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */
/* tau. */
/* H is a product of k elementary reflectors as returned by ZTZRZF. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* L (input) INTEGER */
/* The number of entries of the vector V containing */
/* the meaningful part of the Householder vectors. */
/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
/* V (input) COMPLEX*16 array, dimension (1+(L-1)*abs(INCV)) */
/* The vector v in the representation of H as returned by */
/* ZTZRZF. V is not used if TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0. */
/* TAU (input) COMPLEX*16 */
/* The value tau in the representation of H. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* ===================================================================== */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L")) {
/* Form H * C */
if (tau->r != 0. || tau->i != 0.) {
/* w( 1:n ) = conjg( C( 1, 1:n ) ) */
zcopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
/* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ) */
zgemv_("Conjugate transpose", l, n, &c_b1, &c__[*m - *l + 1 +
c_dim1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__1, &work[1], &c__1, &c__[c_offset], ldc);
/* tau * v( 1:l ) * conjg( w( 1:n )' ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(l, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l +
1 + c_dim1], ldc);
}
} else {
/* Form C * H */
if (tau->r != 0. || tau->i != 0.) {
/* w( 1:m ) = C( 1:m, 1 ) */
zcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1);
/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */
zgemv_("No transpose", m, l, &c_b1, &c__[(*n - *l + 1) * c_dim1 +
1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__1, &work[1], &c__1, &c__[c_offset], &c__1);
/* tau * w( 1:m ) * v( 1:l )' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, l, &z__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l +
1) * c_dim1 + 1], ldc);
}
}
return 0;
/* End of ZLARZ */
} /* zlarz_ */
/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c1, doublecomplex *c2, integer *ldc, doublecomplex *work)
{
/* -- 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
=======
ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix.
Let P = I - tau*u*u', u = ( 1 ),
( v )
where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
SIDE = 'R'.
If SIDE equals 'L', let
C = [ C1 ] 1
[ C2 ] m-1
n
Then C is overwritten by P*C.
If SIDE equals 'R', let
C = [ C1, C2 ] m
1 n-1
Then C is overwritten by C*P.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': form P * C
= 'R': form C * P
M (input) INTEGER
The number of rows of the matrix C.
N (input) INTEGER
The number of columns of the matrix C.
V (input) COMPLEX*16 array, dimension
(1 + (M-1)*abs(INCV)) if SIDE = 'L'
(1 + (N-1)*abs(INCV)) if SIDE = 'R'
The vector v in the representation of P. V is not used
if TAU = 0.
INCV (input) INTEGER
The increment between elements of v. INCV <> 0
TAU (input) COMPLEX*16
The value tau in the representation of P.
C1 (input/output) COMPLEX*16 array, dimension
(LDC,N) if SIDE = 'L'
(M,1) if SIDE = 'R'
On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
if SIDE = 'R'.
On exit, the first row of P*C if SIDE = 'L', or the first
column of C*P if SIDE = 'R'.
C2 (input/output) COMPLEX*16 array, dimension
(LDC, N) if SIDE = 'L'
(LDC, N-1) if SIDE = 'R'
On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
m x (n - 1) matrix C2 if SIDE = 'R'.
On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
if SIDE = 'R'.
LDC (input) INTEGER
The leading dimension of the arrays C1 and C2.
LDC >= max(1,M).
WORK (workspace) COMPLEX*16 array, dimension
(N) if SIDE = 'L'
(M) if SIDE = 'R'
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
doublecomplex z__1;
/* Local variables */
extern logical lsame_(char *, char *);
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 *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), zlacgv_(integer *,
doublecomplex *, integer *);
#define V(I) v[(I)-1]
#define WORK(I) work[(I)-1]
#define C2(I,J) c2[(I)-1 + ((J)-1)* ( *ldc)]
#define C1(I,J) c1[(I)-1 + ((J)-1)* ( *ldc)]
if (min(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) {
return 0;
}
if (lsame_(side, "L")) {
/* w := conjg( C1 + v' * C2 ) */
zcopy_(n, &C1(1,1), ldc, &WORK(1), &c__1);
zlacgv_(n, &WORK(1), &c__1);
i__1 = *m - 1;
zgemv_("Conjugate transpose", &i__1, n, &c_b1, &C2(1,1), ldc, &
V(1), incv, &c_b1, &WORK(1), &c__1);
/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
[ C2 ] [ C2 ] [ v ] */
zlacgv_(n, &WORK(1), &c__1);
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__1, &WORK(1), &c__1, &C1(1,1), ldc);
i__1 = *m - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(&i__1, n, &z__1, &V(1), incv, &WORK(1), &c__1, &C2(1,1),
ldc);
} else if (lsame_(side, "R")) {
/* w := C1 + C2 * v */
zcopy_(m, &C1(1,1), &c__1, &WORK(1), &c__1);
i__1 = *n - 1;
zgemv_("No transpose", m, &i__1, &c_b1, &C2(1,1), ldc, &V(1),
incv, &c_b1, &WORK(1), &c__1);
/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__1, &WORK(1), &c__1, &C1(1,1), &c__1);
i__1 = *n - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, &i__1, &z__1, &WORK(1), &c__1, &V(1), incv, &C2(1,1),
ldc);
}
return 0;
/* End of ZLATZM */
} /* zlatzm_ */
int zlatrd_(char *uplo, int *n, int *nb,
doublecomplex *a, int *lda, double *e, doublecomplex *tau,
doublecomplex *w, int *ldw)
{
/* System generated locals */
int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
double d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
int i__, iw;
doublecomplex alpha;
extern int lsame_(char *, char *);
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *);
extern int zgemv_(char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *),
zhemv_(char *, int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *), zaxpy_(int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *), zlarfg_(int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *), zlacgv_(int *, doublecomplex *,
int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to */
/* Hermitian tridiagonal form by a unitary similarity */
/* transformation Q' * A * Q, and returns the matrices V and W which are */
/* needed to apply the transformation to the unreduced part of A. */
/* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a */
/* matrix, of which the upper triangle is supplied; */
/* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a */
/* matrix, of which the lower triangle is supplied. */
/* This is an auxiliary routine called by ZHETRD. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* NB (input) INTEGER */
/* The number of rows and columns to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit: */
/* if UPLO = 'U', the last NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements above the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors; */
/* if UPLO = 'L', the first NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements below the diagonal */
/* 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,N). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* elements of the last NB columns of the reduced matrix; */
/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* the first NB columns of the reduced matrix. */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors, stored in */
/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* See Further Details. */
/* W (output) COMPLEX*16 array, dimension (LDW,NB) */
/* The n-by-nb matrix W required to update the unreduced part */
/* of A. */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= MAX(1,N). */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n) H(n-1) . . . H(n-nb+1). */
/* 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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* and tau in TAU(i-1). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* 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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
/* and tau in TAU(i). */
/* The elements of the vectors v together form the n-by-nb matrix V */
/* which is needed, with W, to apply the transformation to the unreduced */
/* part of the matrix, using a Hermitian rank-2k update of the form: */
/* A := A - V*W' - W*V'. */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5 and nb = 2: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( a a a v4 v5 ) ( d ) */
/* ( a a v4 v5 ) ( 1 d ) */
/* ( a 1 v5 ) ( v1 1 a ) */
/* ( d 1 ) ( v1 v2 a a ) */
/* ( d ) ( v1 v2 a a a ) */
/* where d denotes a diagonal element of the reduced matrix, a denotes */
/* an element of the original matrix that is unchanged, and vi denotes */
/* an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__
- 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw
+ 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &
c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[(
i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1],
&c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
z__3.r = -.5, z__3.i = -0.;
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = i__ - 1;
zdotc_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ *
a_dim1 + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *n)+ i__ * a_dim1], &c__1,
&tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1
+ w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
z__3.r = -.5, z__3.i = -0.;
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = *n - i__;
zdotc_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[
i__ + 1 + i__ * a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
} /* zlatrd_ */
/* Subroutine */ int zungr2_(integer *m, integer *n, integer *k,
doublecomplex *a, integer *lda, 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
=======
ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,
which is defined as the last m rows of a product of k elementary
reflectors of order n
Q = H(1)' H(2)' . . . H(k)'
as returned by ZGERQF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. N >= M.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the (m-k+i)-th row must contain the vector which
defines the elementary reflector H(i), for i = 1,2,...,k, as
returned by ZGERQF in the last k rows of its array argument
A.
On exit, the m-by-n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) COMPLEX*16 array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by ZGERQF.
WORK (workspace) COMPLEX*16 array, dimension (M)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j, l;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, 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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows 1:m-k to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m - *k;
for (l = 1; l <= i__2; ++l) {
i__3 = a_subscr(l, j);
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
if (j > *n - *m && j <= *n - *k) {
i__2 = a_subscr(*m - *n + j, j);
a[i__2].r = 1., a[i__2].i = 0.;
}
/* L20: */
}
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *m - *k + i__;
/* Apply H(i)' to A(1:m-k+i,1:n-k+i) from the right */
i__2 = *n - *m + ii - 1;
zlacgv_(&i__2, &a_ref(ii, 1), lda);
i__2 = a_subscr(ii, *n - *m + ii);
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = ii - 1;
i__3 = *n - *m + ii;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Right", &i__2, &i__3, &a_ref(ii, 1), lda, &z__1, &a[a_offset],
lda, &work[1]);
i__2 = *n - *m + ii - 1;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zscal_(&i__2, &z__1, &a_ref(ii, 1), lda);
i__2 = *n - *m + ii - 1;
zlacgv_(&i__2, &a_ref(ii, 1), lda);
i__2 = a_subscr(ii, *n - *m + ii);
d_cnjg(&z__2, &tau[i__]);
z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* Set A(m-k+i,n-k+i+1:n) to zero */
i__2 = *n;
for (l = *n - *m + ii + 1; l <= i__2; ++l) {
i__3 = a_subscr(ii, l);
a[i__3].r = 0., a[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of ZUNGR2 */
} /* zungr2_ */
int zlabrd_(int *m, int *n, int *nb,
doublecomplex *a, int *lda, double *d__, double *e,
doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, int *
ldx, doublecomplex *y, int *ldy)
{
/* System generated locals */
int a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
int i__;
doublecomplex alpha;
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *), zgemv_(char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *),
zlarfg_(int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *), zlacgv_(int *, doublecomplex *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLABRD reduces the first NB rows and columns of a complex general */
/* m by n matrix A to upper or lower float bidiagonal form by a unitary */
/* transformation Q' * A * P, and returns the matrices X and Y which */
/* are needed to apply the transformation to the unreduced part of A. */
/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
/* bidiagonal form. */
/* This is an auxiliary routine called by ZGEBRD */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. */
/* NB (input) INTEGER */
/* The number of leading rows and columns of A to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, the first NB rows and columns of the matrix are */
/* overwritten; the rest of the array is unchanged. */
/* If m >= n, elements on and below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the unitary */
/* matrix Q as a product of elementary reflectors; and */
/* elements above the diagonal in the first NB rows, with the */
/* array TAUP, represent the unitary matrix P as a product */
/* of elementary reflectors. */
/* If m < n, elements below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the unitary */
/* matrix Q as a product of elementary reflectors, and */
/* elements on and above the diagonal in the first NB rows, */
/* with the array TAUP, represent the unitary matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (NB) */
/* The diagonal elements of the first NB rows and columns of */
/* the reduced matrix. D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (NB) */
/* The off-diagonal elements of the first NB rows and columns of */
/* the reduced matrix. */
/* TAUQ (output) COMPLEX*16 array dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix Q. See Further Details. */
/* TAUP (output) COMPLEX*16 array, dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the unitary matrix P. See Further Details. */
/* X (output) COMPLEX*16 array, dimension (LDX,NB) */
/* The m-by-nb matrix X required to update the unreduced part */
/* of A. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= MAX(1,M). */
/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y required to update the unreduced part */
/* of A. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= MAX(1,N). */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are complex scalars, and v and u are complex */
/* vectors. */
/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The elements of the vectors v and u together form the m-by-nb matrix */
/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
/* the transformation to the unreduced part of the matrix, using a block */
/* update of the form: A := A - V*Y' - X*U'. */
/* The contents of A on exit are illustrated by the following examples */
/* with nb = 2: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix which is unchanged, */
/* vi denotes an element of the vector defining H(i), and ui an element */
/* of the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
&y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + x_dim1], ldx,
&a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ *
a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *m)+ i__ * a_dim1], &c__1, &
tauq[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
if (i__ < *n) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], &
c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ +
a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ +
x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
y[i__ * y_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
zlacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + (
i__ + 1) * a_dim1], lda);
zlacgv_(&i__, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &
a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
/* Generate reflection P(i) to annihilate A(i,i+2:n) */
i__2 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[i__ + MIN(i__3, *n)* a_dim1], lda, &
taup[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + (i__ + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__
+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1
+ y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b1, &x[i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1],
lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[i__ *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ +
i__ * a_dim1], lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */
i__2 = i__ + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &alpha, &a[i__ + MIN(i__3, *n)* a_dim1], lda, &
taup[i__]);
i__2 = i__;
d__[i__2] = alpha.r;
if (i__ < *m) {
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ *
a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ +
y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 +
1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ *
x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
/* Update A(i+1:m,i) */
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ +
1 + i__ * a_dim1], &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
i__2 = *m - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__, &z__1, &x[i__ + 1 +
x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[
i__ + 1 + i__ * a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *m)+ i__ * a_dim1], &c__1,
&tauq[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1]
, &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1
+ x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &y[i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__, &i__2, &z__1, &a[(i__ + 1)
* a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
} else {
i__2 = *n - i__ + 1;
zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
}
/* L20: */
}
}
return 0;
/* End of ZLABRD */
} /* zlabrd_ */
/* Subroutine */ int zgelq2_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *work, 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
=======
ZGELQ2 computes an LQ factorization of a complex m by n matrix A:
A = L * 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, the elements on and below the diagonal of the array
contain the m by min(m,n) lower trapezoidal matrix L (L is
lower triangular if m <= n); the elements above the diagonal,
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(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(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
A(i,i+1:n), and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i, k;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *,
integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGELQ2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i = 1; i <= k; ++i) {
/* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*/
i__2 = *n - i + 1;
zlacgv_(&i__2, &A(i,i), lda);
i__2 = i + i * a_dim1;
alpha.r = A(i,i).r, alpha.i = A(i,i).i;
i__2 = *n - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &alpha, &A(i,min(i+1,*n)), lda, &TAU(i));
if (i < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
i__2 = *m - i;
i__3 = *n - i + 1;
zlarf_("Right", &i__2, &i__3, &A(i,i), lda, &TAU(i), &
A(i+1,i), lda, &WORK(1));
}
i__2 = i + i * a_dim1;
A(i,i).r = alpha.r, A(i,i).i = alpha.i;
i__2 = *n - i + 1;
zlacgv_(&i__2, &A(i,i), lda);
/* L10: */
}
return 0;
/* End of ZGELQ2 */
} /* zgelq2_ */
/* Subroutine */ int zlatme_(integer *n, char *dist, integer *iseed,
doublecomplex *d, integer *mode, doublereal *cond, doublecomplex *
dmax__, char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
integer *modes, doublereal *conds, integer *kl, integer *ku,
doublereal *anorm, doublecomplex *a, integer *lda, doublecomplex *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical bads;
static integer isim;
static doublereal temp;
static integer i, j;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
static integer iinfo;
static doublereal tempa[1];
static integer icols;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer idist;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer irows;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlatm1_(integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *, integer
*), zlatm1_(integer *, doublereal *, integer *, integer *,
integer *, doublecomplex *, integer *, integer *);
static integer ic, jc, ir;
static doublereal ralpha;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlarge_(integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
static integer irsign;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer iupper;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
static doublecomplex xnorms;
static integer jcr;
static doublecomplex tau;
/* -- LAPACK test 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
=======
ZLATME generates random non-symmetric square matrices with
specified eigenvalues for testing LAPACK programs.
ZLATME operates by applying the following sequence of
operations:
1. Set the diagonal to D, where D may be input or
computed according to MODE, COND, DMAX, and RSIGN
as described below.
2. If UPPER='T', the upper triangle of A is set to random values
out of distribution DIST.
3. If SIM='T', A is multiplied on the left by a random matrix
X, whose singular values are specified by DS, MODES, and
CONDS, and on the right by X inverse.
4. If KL < N-1, the lower bandwidth is reduced to KL using
Householder transformations. If KU < N-1, the upper
bandwidth is reduced to KU.
5. If ANORM is not negative, the matrix is scaled to have
maximum-element-norm ANORM.
(Note: since the matrix cannot be reduced beyond Hessenberg form,
no packing options are available.)
Arguments
=========
N - INTEGER
The number of columns (or rows) of A. Not modified.
DIST - CHARACTER*1
On entry, DIST specifies the type of distribution to be used
to generate the random eigen-/singular values, and on the
upper triangle (see UPPER).
'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
'N' => NORMAL( 0, 1 ) ( 'N' for normal )
'D' => uniform on the complex disc |z| < 1.
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. They should lie between 0 and 4095 inclusive,
and ISEED(4) should be odd. The random number generator
uses a linear congruential sequence limited to small
integers, and so should produce machine independent
random numbers. The values of ISEED are changed on
exit, and can be used in the next call to ZLATME
to continue the same random number sequence.
Changed on exit.
D - COMPLEX*16 array, dimension ( N )
This array is used to specify the eigenvalues of A. If
MODE=0, then D is assumed to contain the eigenvalues
otherwise they will be computed according to MODE, COND,
DMAX, and RSIGN and placed in D.
Modified if MODE is nonzero.
MODE - INTEGER
On entry this describes how the eigenvalues are to
be specified:
MODE = 0 means use D as input
MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
MODE = 5 sets D to random numbers in the range
( 1/COND , 1 ) such that their logarithms
are uniformly distributed.
MODE = 6 set D to random numbers from same distribution
as the rest of the matrix.
MODE < 0 has the same meaning as ABS(MODE), except that
the order of the elements of D is reversed.
Thus if MODE is between 1 and 4, D has entries ranging
from 1 to 1/COND, if between -1 and -4, D has entries
ranging from 1/COND to 1,
Not modified.
COND - DOUBLE PRECISION
On entry, this is used as described under MODE above.
If used, it must be >= 1. Not modified.
DMAX - COMPLEX*16
If MODE is neither -6, 0 nor 6, the contents of D, as
computed according to MODE and COND, will be scaled by
DMAX / max(abs(D(i))). Note that DMAX need not be
positive or real: if DMAX is negative or complex (or zero),
D will be scaled by a negative or complex number (or zero).
If RSIGN='F' then the largest (absolute) eigenvalue will be
equal to DMAX.
Not modified.
EI - CHARACTER*1 (ignored)
Not modified.
RSIGN - CHARACTER*1
If MODE is not 0, 6, or -6, and RSIGN='T', then the
elements of D, as computed according to MODE and COND, will
be multiplied by a random complex number from the unit
circle |z| = 1. If RSIGN='F', they will not be. RSIGN may
only have the values 'T' or 'F'.
Not modified.
UPPER - CHARACTER*1
If UPPER='T', then the elements of A above the diagonal
will be set to random numbers out of DIST. If UPPER='F',
they will not. UPPER may only have the values 'T' or 'F'.
Not modified.
SIM - CHARACTER*1
If SIM='T', then A will be operated on by a "similarity
transform", i.e., multiplied on the left by a matrix X and
on the right by X inverse. X = U S V, where U and V are
random unitary matrices and S is a (diagonal) matrix of
singular values specified by DS, MODES, and CONDS. If
SIM='F', then A will not be transformed.
Not modified.
DS - DOUBLE PRECISION array, dimension ( N )
This array is used to specify the singular values of X,
in the same way that D specifies the eigenvalues of A.
If MODE=0, the DS contains the singular values, which
may not be zero.
Modified if MODE is nonzero.
MODES - INTEGER
CONDS - DOUBLE PRECISION
Similar to MODE and COND, but for specifying the diagonal
of S. MODES=-6 and +6 are not allowed (since they would
result in randomly ill-conditioned eigenvalues.)
KL - INTEGER
This specifies the lower bandwidth of the matrix. KL=1
specifies upper Hessenberg form. If KL is at least N-1,
then A will have full lower bandwidth.
Not modified.
KU - INTEGER
This specifies the upper bandwidth of the matrix. KU=1
specifies lower Hessenberg form. If KU is at least N-1,
then A will have full upper bandwidth; if KU and KL
are both at least N-1, then A will be dense. Only one of
KU and KL may be less than N-1.
Not modified.
ANORM - DOUBLE PRECISION
If ANORM is not negative, then A will be scaled by a non-
negative real number to make the maximum-element-norm of A
to be ANORM.
Not modified.
A - COMPLEX*16 array, dimension ( LDA, N )
On exit A is the desired test matrix.
Modified.
LDA - INTEGER
LDA specifies the first dimension of A as declared in the
calling program. LDA must be at least M.
Not modified.
WORK - COMPLEX*16 array, dimension ( 3*N )
Workspace.
Modified.
INFO - INTEGER
Error code. On exit, INFO will be set to one of the
following values:
0 => normal return
-1 => N negative
-2 => DIST illegal string
-5 => MODE not in range -6 to 6
-6 => COND less than 1.0, and MODE neither -6, 0 nor 6
-9 => RSIGN is not 'T' or 'F'
-10 => UPPER is not 'T' or 'F'
-11 => SIM is not 'T' or 'F'
-12 => MODES=0 and DS has a zero singular value.
-13 => MODES is not in the range -5 to 5.
-14 => MODES is nonzero and CONDS is less than 1.
-15 => KL is less than 1.
-16 => KU is less than 1, or KL and KU are both less than
N-1.
-19 => LDA is less than M.
1 => Error return from ZLATM1 (computing D)
2 => Cannot scale to DMAX (max. eigenvalue is 0)
3 => Error return from DLATM1 (computing DS)
4 => Error return from ZLARGE
5 => Zero singular value from DLATM1.
=====================================================================
1) Decode and Test the input parameters.
Initialize flags & seed.
Parameter adjustments */
--iseed;
--d;
--ds;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else if (lsame_(dist, "D")) {
idist = 4;
} else {
idist = -1;
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.) {
bads = TRUE_;
}
/* L10: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
*info = -6;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i = 1; i <= 4; ++i) {
iseed[i] = (i__1 = iseed[i], abs(i__1)) % 4096;
/* L20: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A
Compute D according to COND and MODE */
zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = z_abs(&d[1]);
i__1 = *n;
for (i = 2; i <= i__1; ++i) {
/* Computing MAX */
d__1 = temp, d__2 = z_abs(&d[i]);
temp = max(d__1,d__2);
/* L30: */
}
if (temp > 0.) {
z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp;
alpha.r = z__1.r, alpha.i = z__1.i;
} else {
*info = 2;
return 0;
}
zscal_(n, &alpha, &d[1], &c__1);
}
zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
i__1 = *lda + 1;
zcopy_(n, &d[1], &c__1, &a[a_offset], &i__1);
/* 3) If UPPER='T', set upper triangle of A to random numbers. */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - 1;
zlarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]);
/* L40: */
}
}
/* 4) If SIM='T', apply similarity transformation.
-1
Transform is X A X , where X = U S V, thus
it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix)
according to CONDS and MODES */
dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zdscal_(n, &ds[j], &a[j + a_dim1], lda);
if (ds[j] != 0.) {
d__1 = 1. / ds[j];
zdscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
} else {
*info = 5;
return 0;
}
/* L50: */
}
/* Multiply by U and U' */
zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
zcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
xnorms.r = work[1].r, xnorms.i = work[1].i;
zlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
d_cnjg(&z__1, &tau);
tau.r = z__1.r, tau.i = z__1.i;
work[1].r = 1., work[1].i = 0.;
zlarnd_(&z__1, &c__5, &iseed[1]);
alpha.r = z__1.r, alpha.i = z__1.i;
zgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1],
lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1);
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&irows, &icols, &z__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a[jcr + (ic + 1) * a_dim1], lda);
zgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1],
&c__1, &c_b1, &work[irows + 1], &c__1);
d_cnjg(&z__2, &tau);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(n, &irows, &z__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a[jcr * a_dim1 + 1], lda);
i__2 = jcr + ic * a_dim1;
a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
i__2 = irows - 1;
zlaset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic *
a_dim1], lda);
i__2 = icols + 1;
zscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda);
d_cnjg(&z__1, &alpha);
zscal_(n, &z__1, &a[jcr * a_dim1 + 1], &c__1);
/* L60: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
zcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
xnorms.r = work[1].r, xnorms.i = work[1].i;
zlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
d_cnjg(&z__1, &tau);
tau.r = z__1.r, tau.i = z__1.i;
work[1].r = 1., work[1].i = 0.;
i__2 = icols - 1;
zlacgv_(&i__2, &work[2], &c__1);
zlarnd_(&z__1, &c__5, &iseed[1]);
alpha.r = z__1.r, alpha.i = z__1.i;
zgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda,
&work[1], &c__1, &c_b1, &work[icols + 1], &c__1);
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&irows, &icols, &z__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a[ir + 1 + jcr * a_dim1], lda);
zgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], &
c__1, &c_b1, &work[icols + 1], &c__1);
d_cnjg(&z__2, &tau);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&icols, n, &z__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a[jcr + a_dim1], lda);
i__2 = ir + jcr * a_dim1;
a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
i__2 = icols - 1;
zlaset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) *
a_dim1], lda);
i__2 = irows + 1;
zscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1);
d_cnjg(&z__1, &alpha);
zscal_(n, &z__1, &a[jcr + a_dim1], lda);
/* L70: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.) {
temp = zlange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.) {
ralpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zdscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1);
/* L80: */
}
}
}
return 0;
/* End of ZLATME */
} /* zlatme_ */
/* Subroutine */
int zungr2_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, l, ii;
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *), zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. 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 < *m)
{
*info = -2;
}
else if (*k < 0 || *k > *m)
{
*info = -3;
}
else if (*lda < max(1,*m))
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZUNGR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0)
{
return 0;
}
if (*k < *m)
{
/* Initialise rows 1:m-k to rows of the unit matrix */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m - *k;
for (l = 1;
l <= i__2;
++l)
{
i__3 = l + j * a_dim1;
a[i__3].r = 0.;
a[i__3].i = 0.; // , expr subst
/* L10: */
}
if (j > *n - *m && j <= *n - *k)
{
i__2 = *m - *n + j + j * a_dim1;
a[i__2].r = 1.;
a[i__2].i = 0.; // , expr subst
}
/* L20: */
}
}
i__1 = *k;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ii = *m - *k + i__;
/* Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right */
i__2 = *n - *m + ii - 1;
zlacgv_(&i__2, &a[ii + a_dim1], lda);
i__2 = ii + (*n - *m + ii) * a_dim1;
a[i__2].r = 1.;
a[i__2].i = 0.; // , expr subst
i__2 = ii - 1;
i__3 = *n - *m + ii;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &z__1, &a[ a_offset], lda, &work[1]);
i__2 = *n - *m + ii - 1;
i__3 = i__;
z__1.r = -tau[i__3].r;
z__1.i = -tau[i__3].i; // , expr subst
zscal_(&i__2, &z__1, &a[ii + a_dim1], lda);
i__2 = *n - *m + ii - 1;
zlacgv_(&i__2, &a[ii + a_dim1], lda);
i__2 = ii + (*n - *m + ii) * a_dim1;
d_cnjg(&z__2, &tau[i__]);
z__1.r = 1. - z__2.r;
z__1.i = 0. - z__2.i; // , expr subst
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
/* Set A(m-k+i,n-k+i+1:n) to zero */
i__2 = *n;
for (l = *n - *m + ii + 1;
l <= i__2;
++l)
{
i__3 = ii + l * a_dim1;
a[i__3].r = 0.;
a[i__3].i = 0.; // , expr subst
/* L30: */
}
/* L40: */
}
return 0;
/* End of ZUNGR2 */
}
/* Subroutine */ int zlagge_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *d__, doublecomplex *a, integer *lda, integer *iseed,
doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex wa, wb;
doublereal wn;
doublecomplex tau;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, integer *), zlarnv_(integer *,
integer *, integer *, doublecomplex *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAGGE generates a complex general m by n matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with random unitary matrices: */
/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
/* kl and ku by additional unitary transformations. */
/* 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. */
/* KL (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* The number of nonzero superdiagonals within the band of A. */
/* 0 <= KU <= N-1. */
/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The generated m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= M. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX*16 array, dimension (M+N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0 || *kl > *m - 1) {
*info = -3;
} else if (*ku < 0 || *ku > *n - 1) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -7;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGGE", &i__1);
return 0;
}
/* initialize A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
/* L30: */
}
/* pre- and post-multiply A by random unitary matrices */
for (i__ = min(*m,*n); i__ >= 1; --i__) {
if (i__ < *m) {
/* generate random reflection */
i__1 = *m - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *m - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *m - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* multiply A(i:m,i:n) by random reflection from the left */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
zgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ *
a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__1, &i__2, &z__1, &work[1], &c__1, &work[*m + 1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
if (i__ < *n) {
/* generate random reflection */
i__1 = *n - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* multiply A(i:m,i:n) by random reflection from the right */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
zgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1]
, lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__1, &i__2, &z__1, &work[*n + 1], &c__1, &work[1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
/* L40: */
}
/* Reduce number of subdiagonals to KL and number of superdiagonals */
/* to KU */
/* Computing MAX */
i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
i__1 = max(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
if (*kl <= *ku) {
/* annihilate subdiagonal elements first (necessary if KL = 0) */
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *m - *kl - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
i__2 = *kl + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *ku - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
i__2 = i__ + (*ku + i__) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *n - *ku - i__ + 1;
zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
lda, &c_b1, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
} else {
/* annihilate superdiagonal elements first (necessary if */
/* KU = 0) */
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *ku - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
i__2 = i__ + (*ku + i__) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *n - *ku - i__ + 1;
zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
lda, &c_b1, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *m - *kl - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
i__2 = *kl + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
i__2 = *m;
for (j = *kl + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
i__2 = *n;
for (j = *ku + i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L60: */
}
/* L70: */
}
return 0;
/* End of ZLAGGE */
} /* zlagge_ */
/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb,
doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau,
doublecomplex *w, integer *ldw)
{
/* -- LAPACK auxiliary 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
=======
ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
Hermitian tridiagonal form by a unitary similarity
transformation Q' * A * Q, and returns the matrices V and W which are
needed to apply the transformation to the unreduced part of A.
If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
matrix, of which the upper triangle is supplied;
if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
matrix, of which the lower triangle is supplied.
This is an auxiliary routine called by ZHETRD.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A.
NB (input) INTEGER
The number of rows and columns to be reduced.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit:
if UPLO = 'U', the last NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements above the diagonal
with the array TAU, represent the unitary matrix Q as a
product of elementary reflectors;
if UPLO = 'L', the first NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements below the diagonal
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,N).
E (output) DOUBLE PRECISION array, dimension (N-1)
If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
elements of the last NB columns of the reduced matrix;
if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
the first NB columns of the reduced matrix.
TAU (output) COMPLEX*16 array, dimension (N-1)
The scalar factors of the elementary reflectors, stored in
TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
See Further Details.
W (output) COMPLEX*16 array, dimension (LDW,NB)
The n-by-nb matrix W required to update the unreduced part
of A.
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n) H(n-1) . . . H(n-nb+1).
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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
and tau in TAU(i-1).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(nb).
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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
and tau in TAU(i).
The elements of the vectors v together form the n-by-nb matrix V
which is needed, with W, to apply the transformation to the unreduced
part of the matrix, using a Hermitian rank-2k update of the form:
A := A - V*W' - W*V'.
The contents of A on exit are illustrated by the following examples
with n = 5 and nb = 2:
if UPLO = 'U': if UPLO = 'L':
( a a a v4 v5 ) ( d )
( a a v4 v5 ) ( 1 d )
( a 1 v5 ) ( v1 1 a )
( d 1 ) ( v1 v2 a a )
( d ) ( v1 v2 a a a )
where d denotes a diagonal element of the reduced matrix, a denotes
an element of the original matrix that is unchanged, and vi denotes
an element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer iw;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
doublecomplex *, 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 w_subscr(a_1,a_2) (a_2)*w_dim1 + a_1
#define w_ref(a_1,a_2) w[w_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &w_ref(i__, iw + 1), ldw);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &a_ref(1, i__ + 1),
lda, &w_ref(i__, iw + 1), ldw, &c_b2, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w_ref(i__, iw + 1), ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &w_ref(1, iw + 1),
ldw, &a_ref(i__, i__ + 1), lda, &c_b2, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate
A(1:i-2,i) */
i__2 = a_subscr(i__ - 1, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a_ref(1, i__), &c__1, &tau[i__ - 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = a_subscr(i__ - 1, i__);
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a_ref(1,
i__), &c__1, &c_b1, &w_ref(1, iw), &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w_ref(
1, iw + 1), ldw, &a_ref(1, i__), &c__1, &c_b1, &
w_ref(i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(1, i__
+ 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b2, &
w_ref(1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(
1, i__ + 1), lda, &a_ref(1, i__), &c__1, &c_b1, &
w_ref(i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(1, iw
+ 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b2, &
w_ref(1, iw), &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
z__3.r = -.5, z__3.i = 0.;
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = i__ - 1;
zdotc_(&z__4, &i__3, &w_ref(1, iw), &c__1, &a_ref(1, i__), &
c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &w_ref(i__, 1), ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(i__, 1), lda, &
w_ref(i__, 1), ldw, &c_b2, &a_ref(i__, i__), &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w_ref(i__, 1), ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(i__, 1), ldw, &
a_ref(i__, 1), lda, &c_b2, &a_ref(i__, i__), &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate
A(i+2:n,i) */
i__2 = a_subscr(i__ + 1, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
zlarfg_(&i__3, &alpha, &a_ref(min(i__2,*n), i__), &c__1, &tau[
i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = a_subscr(i__ + 1, i__);
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b1, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w_ref(i__
+ 1, 1), ldw, &a_ref(i__ + 1, i__), &c__1, &c_b1, &
w_ref(1, i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(i__ + 1, 1)
, lda, &w_ref(1, i__), &c__1, &c_b2, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &c_b1, &
w_ref(1, i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(i__ + 1, 1)
, ldw, &w_ref(1, i__), &c__1, &c_b2, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
z__3.r = -.5, z__3.i = 0.;
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = *n - i__;
zdotc_(&z__4, &i__3, &w_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__
+ 1, i__), &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
} /* zlatrd_ */
/*< SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) >*/
/* Subroutine */ int zlarft_(char *direct, char *storev, integer *n, integer *
k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *
t, integer *ldt, ftnlen direct_len, ftnlen storev_len)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
integer i__, j;
doublecomplex vii;
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
ztrmv_(char *, char *, char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen),
zlacgv_(integer *, doublecomplex *, integer *);
(void)direct_len;
(void)storev_len;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/*< CHARACTER DIRECT, STOREV >*/
/*< INTEGER K, LDT, LDV, N >*/
/* .. */
/* .. Array Arguments .. */
/*< COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZLARFT forms the triangular factor T of a complex block reflector H */
/* of order n, which is defined as a product of k elementary reflectors. */
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) COMPLEX*16 array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) COMPLEX*16 array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* The shape of the matrix V and the storage of the vectors which define */
/* the H(i) is best illustrated by the following example with n = 5 and */
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
/* ( v1 1 ) ( 1 v2 v2 v2 ) */
/* ( v1 v2 1 ) ( 1 v3 v3 ) */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
/* ( 1 v3 ) */
/* ( 1 ) */
/* ===================================================================== */
/* .. Parameters .. */
/*< COMPLEX*16 ONE, ZERO >*/
/*< >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, J >*/
/*< COMPLEX*16 VII >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL ZGEMV, ZLACGV, ZTRMV >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/*< >*/
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
/*< IF( LSAME( DIRECT, 'F' ) ) THEN >*/
if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
/*< DO 20 I = 1, K >*/
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< IF( TAU( I ).EQ.ZERO ) THEN >*/
i__2 = i__;
if (tau[i__2].r == 0. && tau[i__2].i == 0.) {
/* H(i) = I */
/*< DO 10 J = 1, I >*/
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
/*< T( J, I ) = ZERO >*/
i__3 = j + i__ * t_dim1;
t[i__3].r = 0., t[i__3].i = 0.;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< ELSE >*/
} else {
/* general case */
/*< VII = V( I, I ) >*/
i__2 = i__ + i__ * v_dim1;
vii.r = v[i__2].r, vii.i = v[i__2].i;
/*< V( I, I ) = ONE >*/
i__2 = i__ + i__ * v_dim1;
v[i__2].r = 1., v[i__2].i = 0.;
/*< IF( LSAME( STOREV, 'C' ) ) THEN >*/
if (lsame_(storev, "C", (ftnlen)1, (ftnlen)1)) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
/*< >*/
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
i__4 = i__;
z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__
+ v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &
c_b2, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)19);
/*< ELSE >*/
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
/*< >*/
if (i__ < *n) {
i__2 = *n - i__;
zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
}
/*< >*/
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
i__4 = i__;
z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i;
zgemv_("No transpose", &i__2, &i__3, &z__1, &v[i__ *
v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
c_b2, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)12);
/*< >*/
if (i__ < *n) {
i__2 = *n - i__;
zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
}
/*< END IF >*/
}
/*< V( I, I ) = VII >*/
i__2 = i__ + i__ * v_dim1;
v[i__2].r = vii.r, v[i__2].i = vii.i;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
/*< >*/
i__2 = i__ - 1;
ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)
5, (ftnlen)12, (ftnlen)8);
/*< T( I, I ) = TAU( I ) >*/
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/*< END IF >*/
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< ELSE >*/
} else {
/*< DO 40 I = K, 1, -1 >*/
for (i__ = *k; i__ >= 1; --i__) {
/*< IF( TAU( I ).EQ.ZERO ) THEN >*/
i__1 = i__;
if (tau[i__1].r == 0. && tau[i__1].i == 0.) {
/* H(i) = I */
/*< DO 30 J = I, K >*/
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
/*< T( J, I ) = ZERO >*/
i__2 = j + i__ * t_dim1;
t[i__2].r = 0., t[i__2].i = 0.;
/*< 30 CONTINUE >*/
/* L30: */
}
/*< ELSE >*/
} else {
/* general case */
/*< IF( I.LT.K ) THEN >*/
if (i__ < *k) {
/*< IF( LSAME( STOREV, 'C' ) ) THEN >*/
if (lsame_(storev, "C", (ftnlen)1, (ftnlen)1)) {
/*< VII = V( N-K+I, I ) >*/
i__1 = *n - *k + i__ + i__ * v_dim1;
vii.r = v[i__1].r, vii.i = v[i__1].i;
/*< V( N-K+I, I ) = ONE >*/
i__1 = *n - *k + i__ + i__ * v_dim1;
v[i__1].r = 1., v[i__1].i = 0.;
/* T(i+1:k,i) := */
/* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
/*< >*/
i__1 = *n - *k + i__;
i__2 = *k - i__;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[
(i__ + 1) * v_dim1 + 1], ldv, &v[i__ * v_dim1
+ 1], &c__1, &c_b2, &t[i__ + 1 + i__ * t_dim1]
, &c__1, (ftnlen)19);
/*< V( N-K+I, I ) = VII >*/
i__1 = *n - *k + i__ + i__ * v_dim1;
v[i__1].r = vii.r, v[i__1].i = vii.i;
/*< ELSE >*/
} else {
/*< VII = V( I, N-K+I ) >*/
i__1 = i__ + (*n - *k + i__) * v_dim1;
vii.r = v[i__1].r, vii.i = v[i__1].i;
/*< V( I, N-K+I ) = ONE >*/
i__1 = i__ + (*n - *k + i__) * v_dim1;
v[i__1].r = 1., v[i__1].i = 0.;
/* T(i+1:k,i) := */
/* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
/*< CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) >*/
i__1 = *n - *k + i__ - 1;
zlacgv_(&i__1, &v[i__ + v_dim1], ldv);
/*< >*/
i__1 = *k - i__;
i__2 = *n - *k + i__;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("No transpose", &i__1, &i__2, &z__1, &v[i__ +
1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, &
c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1, (
ftnlen)12);
/*< CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) >*/
i__1 = *n - *k + i__ - 1;
zlacgv_(&i__1, &v[i__ + v_dim1], ldv);
/*< V( I, N-K+I ) = VII >*/
i__1 = i__ + (*n - *k + i__) * v_dim1;
v[i__1].r = vii.r, v[i__1].i = vii.i;
/*< END IF >*/
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
/*< >*/
i__1 = *k - i__;
ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8)
;
/*< END IF >*/
}
/*< T( I, I ) = TAU( I ) >*/
i__1 = i__ + i__ * t_dim1;
i__2 = i__;
t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
/*< END IF >*/
}
/*< 40 CONTINUE >*/
/* L40: */
}
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of ZLARFT */
/*< END >*/
} /* zlarft_ */
/* 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_ */
/* Subroutine */ int zlahrd_(integer *n, integer *k, integer *nb,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
integer *ldt, doublecomplex *y, integer *ldy)
{
/* -- LAPACK auxiliary 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
=======
ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
matrix A so that elements below the k-th subdiagonal are zero. The
reduction is performed by a unitary similarity transformation
Q' * A * Q. The routine returns the matrices V and T which determine
Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
This is an auxiliary routine called by ZGEHRD.
Arguments
=========
N (input) INTEGER
The order of the matrix A.
K (input) INTEGER
The offset for the reduction. Elements below the k-th
subdiagonal in the first NB columns are reduced to zero.
NB (input) INTEGER
The number of columns to be reduced.
A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)
On entry, the n-by-(n-k+1) general matrix A.
On exit, the elements on and above the k-th subdiagonal in
the first NB columns are overwritten with the corresponding
elements of the reduced matrix; the elements below the k-th
subdiagonal, with the array TAU, represent the matrix Q as a
product of elementary reflectors. The other columns of A are
unchanged. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
TAU (output) COMPLEX*16 array, dimension (NB)
The scalar factors of the elementary reflectors. See Further
Details.
T (output) COMPLEX*16 array, dimension (NB,NB)
The upper triangular matrix T.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= NB.
Y (output) COMPLEX*16 array, dimension (LDY,NB)
The n-by-nb matrix Y.
LDY (input) INTEGER
The leading dimension of the array Y. LDY >= max(1,N).
Further Details
===============
The matrix Q is represented as a product of nb elementary reflectors
Q = H(1) H(2) . . . H(nb).
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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
A(i+k+1:n,i), and tau in TAU(i).
The elements of the vectors v together form the (n-k+1)-by-nb matrix
V which is needed, with T and Y, to apply the transformation to the
unreduced part of the matrix, using an update of the form:
A := (I - V*T*V') * (A - Y*V').
The contents of A on exit are illustrated by the following example
with n = 7, k = 3 and nb = 2:
( a h a a a )
( a h a a a )
( a h a a a )
( h h a a a )
( v1 h a a a )
( v1 v2 a a a )
( v1 v2 a a a )
where a denotes an element of the original matrix A, h denotes a
modified element of the upper Hessenberg matrix H, and vi denotes an
element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
static integer i;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
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 *), ztrmv_(char *, char *,
char *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static doublecomplex ei;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
doublecomplex *, integer *);
#define TAU(I) tau[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define Y(I,J) y[(I)-1 + ((J)-1)* ( *ldy)]
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i = 1; i <= *nb; ++i) {
if (i > 1) {
/* Update A(1:n,i)
Compute i-th column of A - Y * V' */
i__2 = i - 1;
zlacgv_(&i__2, &A(*k+i-1,1), lda);
i__2 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", n, &i__2, &z__1, &Y(1,1), ldy, &A(*k+i-1,1), lda, &c_b2, &A(1,i), &c__1);
i__2 = i - 1;
zlacgv_(&i__2, &A(*k+i-1,1), lda);
/* Apply I - V * T' * V' to this column (call it b) from
the
left, using the last column of T as workspace
Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
( V2 ) ( b2 )
where V1 is unit lower triangular
w := V1' * b1 */
i__2 = i - 1;
zcopy_(&i__2, &A(*k+1,i), &c__1, &T(1,*nb)
, &c__1);
i__2 = i - 1;
ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &A(*k+1,1), lda, &T(1,*nb), &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i + 1;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(*k+i,1), lda, &A(*k+i,i), &c__1, &c_b2, &T(1,*nb), &c__1);
/* w := T'*w */
i__2 = i - 1;
ztrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &T(1,1), ldt, &T(1,*nb), &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i + 1;
i__3 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &A(*k+i,1),
lda, &T(1,*nb), &c__1, &c_b2, &A(*k+i,i), &c__1);
/* b1 := b1 - V1*w */
i__2 = i - 1;
ztrmv_("Lower", "No transpose", "Unit", &i__2, &A(*k+1,1)
, lda, &T(1,*nb), &c__1);
i__2 = i - 1;
z__1.r = -1., z__1.i = 0.;
zaxpy_(&i__2, &z__1, &T(1,*nb), &c__1, &A(*k+1,i), &c__1);
i__2 = *k + i - 1 + (i - 1) * a_dim1;
A(*k+i-1,i-1).r = ei.r, A(*k+i-1,i-1).i = ei.i;
}
/* Generate the elementary reflector H(i) to annihilate
A(k+i+1:n,i) */
i__2 = *k + i + i * a_dim1;
ei.r = A(*k+i,i).r, ei.i = A(*k+i,i).i;
i__2 = *n - *k - i + 1;
/* Computing MIN */
i__3 = *k + i + 1;
zlarfg_(&i__2, &ei, &A(min(*k+i+1,*n),i), &c__1, &TAU(i));
i__2 = *k + i + i * a_dim1;
A(*k+i,i).r = 1., A(*k+i,i).i = 0.;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i + 1;
zgemv_("No transpose", n, &i__2, &c_b2, &A(1,i+1), lda,
&A(*k+i,i), &c__1, &c_b1, &Y(1,i), &
c__1);
i__2 = *n - *k - i + 1;
i__3 = i - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &A(*k+i,1)
, lda, &A(*k+i,i), &c__1, &c_b1, &T(1,i), &c__1);
i__2 = i - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", n, &i__2, &z__1, &Y(1,1), ldy, &T(1,i), &c__1, &c_b2, &Y(1,i), &c__1);
zscal_(n, &TAU(i), &Y(1,i), &c__1);
/* Compute T(1:i,i) */
i__2 = i - 1;
i__3 = i;
z__1.r = -TAU(i).r, z__1.i = -TAU(i).i;
zscal_(&i__2, &z__1, &T(1,i), &c__1);
i__2 = i - 1;
ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &T(1,1), ldt,
&T(1,i), &c__1);
i__2 = i + i * t_dim1;
i__3 = i;
T(i,i).r = TAU(i).r, T(i,i).i = TAU(i).i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
A(*k+*nb,*nb).r = ei.r, A(*k+*nb,*nb).i = ei.i;
return 0;
/* End of ZLAHRD */
} /* zlahrd_ */
/* Subroutine */ int zunmr2_(char *side, char *trans, integer *m, integer *n,
integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
doublecomplex *c__, integer *ldc, 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
=======
ZUNMR2 overwrites the general complex m-by-n matrix C with
Q * C if SIDE = 'L' and TRANS = 'N', or
Q'* C if SIDE = 'L' and TRANS = 'C', or
C * Q if SIDE = 'R' and TRANS = 'N', or
C * Q' if SIDE = 'R' and TRANS = 'C',
where Q is a complex unitary matrix defined as the product of k
elementary reflectors
Q = H(1)' H(2)' . . . H(k)'
as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n
if SIDE = 'R'.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q' from the Left
= 'R': apply Q or Q' from the Right
TRANS (input) CHARACTER*1
= 'N': apply Q (No transpose)
= 'C': apply Q' (Conjugate transpose)
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines
the matrix Q.
If SIDE = 'L', M >= K >= 0;
if SIDE = 'R', N >= K >= 0.
A (input) COMPLEX*16 array, dimension
(LDA,M) if SIDE = 'L',
(LDA,N) if SIDE = 'R'
The i-th row must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
ZGERQF in the last k rows of its array argument A.
A is modified by the routine but restored on exit.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,K).
TAU (input) COMPLEX*16 array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by ZGERQF.
C (input/output) COMPLEX*16 array, dimension (LDC,N)
On entry, the m-by-n matrix C.
On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) COMPLEX*16 array, dimension
(N) if SIDE = 'L',
(M) if SIDE = 'R'
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical left;
static doublecomplex taui;
static integer i__;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
static integer i1, i2, i3, mi, ni, nq;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static logical notran;
static doublecomplex aii;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,*k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNMR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) or H(i)' is applied to C(1:m-k+i,1:n) */
mi = *m - *k + i__;
} else {
/* H(i) or H(i)' is applied to C(1:m,1:n-k+i) */
ni = *n - *k + i__;
}
/* Apply H(i) or H(i)' */
if (notran) {
d_cnjg(&z__1, &tau[i__]);
taui.r = z__1.r, taui.i = z__1.i;
} else {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
}
i__3 = nq - *k + i__ - 1;
zlacgv_(&i__3, &a_ref(i__, 1), lda);
i__3 = a_subscr(i__, nq - *k + i__);
aii.r = a[i__3].r, aii.i = a[i__3].i;
i__3 = a_subscr(i__, nq - *k + i__);
a[i__3].r = 1., a[i__3].i = 0.;
zlarf_(side, &mi, &ni, &a_ref(i__, 1), lda, &taui, &c__[c_offset],
ldc, &work[1]);
i__3 = a_subscr(i__, nq - *k + i__);
a[i__3].r = aii.r, a[i__3].i = aii.i;
i__3 = nq - *k + i__ - 1;
zlacgv_(&i__3, &a_ref(i__, 1), lda);
/* L10: */
}
return 0;
/* End of ZUNMR2 */
} /* zunmr2_ */
/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb,
doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
integer *ldw, 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
=======
ZLAHEF computes a partial factorization of a complex Hermitian
matrix A using the Bunch-Kaufman diagonal pivoting method. The
partial factorization has the form:
A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
( 0 U22 ) ( 0 D ) ( U12' U22' )
A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
( L21 I ) ( 0 A22 ) ( 0 I )
where the order of D is at most NB. The actual order is returned in
the argument KB, and is either NB or NB-1, or N if N <= NB.
Note that U' denotes the conjugate transpose of U.
ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code
(calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
A22 (if UPLO = 'L').
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
NB (input) INTEGER
The maximum number of columns of the matrix A that should be
factored. NB should be at least 2 to allow for 2-by-2 pivot
blocks.
KB (output) INTEGER
The number of columns of A that were actually factored.
KB is either NB-1 or NB, or N if N <= NB.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, A contains details of the partial factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D.
If UPLO = 'U', only the last KB elements of IPIV are set;
if UPLO = 'L', only the first KB elements are set.
If IPIV(k) > 0, then rows and columns k and IPIV(k) were
interchanged and D(k,k) is a 1-by-1 diagonal block.
If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
W (workspace) COMPLEX*16 array, dimension (LDW,NB)
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = k, D(k,k) is exactly zero. The factorization
has been completed, but the block diagonal matrix D is
exactly singular.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *,
doublecomplex *, doublecomplex *);
/* Local variables */
static integer imax, jmax, j, k;
static doublereal t, alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer kstep;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static doublereal r1;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
static doublecomplex d11, d21, d22;
static integer jb, jj, kk, jp, kp;
static doublereal absakk;
static integer kw;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal colmax;
extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
;
extern integer izamax_(integer *, doublecomplex *, integer *);
static doublereal rowmax;
static integer kkw;
#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 w_subscr(a_1,a_2) (a_2)*w_dim1 + a_1
#define w_ref(a_1,a_2) w[w_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (lsame_(uplo, "U")) {
/* Factorize the trailing columns of A using the upper triangle
of A and working backwards, and compute the matrix W = U12*D
for use in updating A11 (note that conjg(W) is actually stored)
K is the main loop index, decreasing from N in steps of 1 or 2
KW is the column of W which corresponds to column K of A */
k = *n;
L10:
kw = *nb + k - *n;
/* Exit from loop */
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
/* Copy column K of A to column KW of W and update it */
i__1 = k - 1;
zcopy_(&i__1, &a_ref(1, k), &c__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1), lda, &
w_ref(k, kw + 1), ldw, &c_b1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = w_subscr(k, kw);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = w_subscr(k, kw);
absakk = (d__1 = w[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(imax, kw);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, kw)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column KW-1 of W and update it */
i__1 = imax - 1;
zcopy_(&i__1, &a_ref(1, imax), &c__1, &w_ref(1, kw - 1), &
c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
i__1 = k - imax;
zcopy_(&i__1, &a_ref(imax, imax + 1), lda, &w_ref(imax + 1,
kw - 1), &c__1);
i__1 = k - imax;
zlacgv_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1),
lda, &w_ref(imax, kw + 1), ldw, &c_b1, &w_ref(1,
kw - 1), &c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = w_subscr(imax, kw - 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
i__1 = w_subscr(jmax, kw - 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, kw - 1)), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &w_ref(1, kw - 1), &c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, kw - 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, kw - 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, kw - 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
/* copy column KW-1 of W to column KW */
zcopy_(&k, &w_ref(1, kw - 1), &c__1, &w_ref(1, kw), &
c__1);
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
/* Updated column KP is already stored in column KKW of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kk - 1 - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp, kp + 1),
lda);
i__1 = kk - 1 - kp;
zlacgv_(&i__1, &a_ref(kp, kp + 1), lda);
i__1 = kp - 1;
zcopy_(&i__1, &a_ref(1, kk), &c__1, &a_ref(1, kp), &c__1);
/* Interchange rows KK and KP in last KK columns of A and W */
if (kk < *n) {
i__1 = *n - kk;
zswap_(&i__1, &a_ref(kk, kk + 1), lda, &a_ref(kp, kk + 1),
lda);
}
i__1 = *n - kk + 1;
zswap_(&i__1, &w_ref(kk, kkw), ldw, &w_ref(kp, kkw), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column KW of W now holds
W(k) = U(k)*D(k)
where U(k) is the k-th column of U
Store U(k) in column k of A */
zcopy_(&k, &w_ref(1, kw), &c__1, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = k - 1;
zdscal_(&i__1, &r1, &a_ref(1, k), &c__1);
/* Conjugate W(k) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
} else {
/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
hold
( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
where U(k) and U(k-1) are the k-th and (k-1)-th columns
of U */
if (k > 2) {
/* Store U(k) and U(k-1) in columns k and k-1 of A */
i__1 = w_subscr(k - 1, kw);
d21.r = w[i__1].r, d21.i = w[i__1].i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, kw), &z__2);
d11.r = z__1.r, d11.i = z__1.i;
z_div(&z__1, &w_ref(k - 1, kw - 1), &d21);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = a_subscr(j, k - 1);
i__3 = w_subscr(j, kw - 1);
z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, kw);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, kw);
z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, kw - 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L20: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k - 1, k - 1);
i__2 = w_subscr(k - 1, kw - 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k - 1, k);
i__2 = w_subscr(k - 1, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k-1) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
i__1 = k - 2;
zlacgv_(&i__1, &w_ref(1, kw - 1), &c__1);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
L30:
/* Update the upper triangle of A11 (= A(1:k,1:k)) as
A11 := A11 - U12*D*U12' = A11 - U12*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
i__1) {
/* Computing MIN */
i__2 = *nb, i__3 = k - j + 1;
jb = min(i__2,i__3);
/* Update the upper triangle of the diagonal block */
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
i__3 = jj - j + 1;
i__4 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__3, &i__4, &z__1, &a_ref(j, k + 1),
lda, &w_ref(jj, kw + 1), ldw, &c_b1, &a_ref(j, jj), &
c__1);
i__3 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &
a_ref(1, k + 1), lda, &w_ref(j, kw + 1), ldw, &c_b1, &
a_ref(1, j), lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchanges
in columns k+1:n */
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
zswap_(&i__1, &a_ref(jp, j), lda, &a_ref(jj, j), lda);
}
if (j <= *n) {
goto L60;
}
/* Set KB to the number of columns factorized */
*kb = *n - k;
} else {
/* Factorize the leading columns of A using the lower triangle
of A and working forwards, and compute the matrix W = L21*D
for use in updating A22 (note that conjg(W) is actually stored)
K is the main loop index, increasing from 1 in steps of 1 or 2 */
k = 1;
L70:
/* Exit from loop */
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
/* Copy column K of A to column K of W and update it */
i__1 = w_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &w_ref(k + 1, k), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda, &w_ref(
k, 1), ldw, &c_b1, &w_ref(k, k), &c__1);
i__1 = w_subscr(k, k);
i__2 = w_subscr(k, k);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = w_subscr(k, k);
absakk = (d__1 = w[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = w_subscr(imax, k);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, k)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column K+1 of W and update it */
i__1 = imax - k;
zcopy_(&i__1, &a_ref(imax, k), lda, &w_ref(k, k + 1), &c__1);
i__1 = imax - k;
zlacgv_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (imax < *n) {
i__1 = *n - imax;
zcopy_(&i__1, &a_ref(imax + 1, imax), &c__1, &w_ref(imax
+ 1, k + 1), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda,
&w_ref(imax, 1), ldw, &c_b1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = w_subscr(imax, k + 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(jmax, k + 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, k + 1)), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &w_ref(imax + 1, k + 1), &
c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, k + 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, k + 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, k + 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
/* copy column K+1 of W to column K */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k + 1), &c__1, &w_ref(k, k), &
c__1);
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
/* Updated column KP is already stored in column KK of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp - kk - 1;
zcopy_(&i__1, &a_ref(kk + 1, kk), &c__1, &a_ref(kp, kk + 1),
lda);
i__1 = kp - kk - 1;
zlacgv_(&i__1, &a_ref(kp, kk + 1), lda);
if (kp < *n) {
i__1 = *n - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp + 1,
kp), &c__1);
}
/* Interchange rows KK and KP in first KK columns of A and W */
i__1 = kk - 1;
zswap_(&i__1, &a_ref(kk, 1), lda, &a_ref(kp, 1), lda);
zswap_(&kk, &w_ref(kk, 1), ldw, &w_ref(kp, 1), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k of W now holds
W(k) = L(k)*D(k)
where L(k) is the k-th column of L
Store L(k) in column k of A */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k), &c__1, &a_ref(k, k), &c__1);
if (k < *n) {
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = *n - k;
zdscal_(&i__1, &r1, &a_ref(k + 1, k), &c__1);
/* Conjugate W(k) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
where L(k) and L(k+1) are the k-th and (k+1)-th columns
of L */
if (k < *n - 1) {
/* Store L(k) and L(k+1) in columns k and k+1 of A */
i__1 = w_subscr(k + 1, k);
d21.r = w[i__1].r, d21.i = w[i__1].i;
z_div(&z__1, &w_ref(k + 1, k + 1), &d21);
d11.r = z__1.r, d11.i = z__1.i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, k), &z__2);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, k);
z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, k + 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k + 1);
i__3 = w_subscr(j, k + 1);
z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, k);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L80: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k);
i__2 = w_subscr(k + 1, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k + 1);
i__2 = w_subscr(k + 1, k + 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k+1) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = *n - k - 1;
zlacgv_(&i__1, &w_ref(k + 2, k + 1), &c__1);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L70;
L90:
/* Update the lower triangle of A22 (= A(k:n,k:n)) as
A22 := A22 - L21*D*L21' = A22 - L21*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
i__1 = *n;
i__2 = *nb;
for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = *nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
/* Update the lower triangle of the diagonal block */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
i__4 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
i__4 = j + jb - jj;
i__5 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__4, &i__5, &z__1, &a_ref(jj, 1),
lda, &w_ref(jj, 1), ldw, &c_b1, &a_ref(jj, jj), &c__1);
i__4 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1,
&a_ref(j + jb, 1), lda, &w_ref(j, 1), ldw, &c_b1, &
a_ref(j + jb, j), lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchanges
in columns 1:k-1 */
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
zswap_(&j, &a_ref(jp, 1), lda, &a_ref(jj, 1), lda);
}
if (j >= 1) {
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of ZLAHEF */
} /* zlahef_ */
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 zlarft_(char *direct, char *storev, integer *n, integer *
k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *
t, integer *ldt)
{
/* -- LAPACK auxiliary 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
=======
ZLARFT forms the triangular factor T of a complex block reflector H
of order n, which is defined as a product of k elementary reflectors.
If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
If STOREV = 'C', the vector which defines the elementary reflector
H(i) is stored in the i-th column of the array V, and
H = I - V * T * V'
If STOREV = 'R', the vector which defines the elementary reflector
H(i) is stored in the i-th row of the array V, and
H = I - V' * T * V
Arguments
=========
DIRECT (input) CHARACTER*1
Specifies the order in which the elementary reflectors are
multiplied to form the block reflector:
= 'F': H = H(1) H(2) . . . H(k) (Forward)
= 'B': H = H(k) . . . H(2) H(1) (Backward)
STOREV (input) CHARACTER*1
Specifies how the vectors which define the elementary
reflectors are stored (see also Further Details):
= 'C': columnwise
= 'R': rowwise
N (input) INTEGER
The order of the block reflector H. N >= 0.
K (input) INTEGER
The order of the triangular factor T (= the number of
elementary reflectors). K >= 1.
V (input/output) COMPLEX*16 array, dimension
(LDV,K) if STOREV = 'C'
(LDV,N) if STOREV = 'R'
The matrix V. See further details.
LDV (input) INTEGER
The leading dimension of the array V.
If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
TAU (input) COMPLEX*16 array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i).
T (output) COMPLEX*16 array, dimension (LDT,K)
The k by k triangular factor T of the block reflector.
If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
lower triangular. The rest of the array is not used.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= K.
Further Details
===============
The shape of the matrix V and the storage of the vectors which define
the H(i) is best illustrated by the following example with n = 5 and
k = 3. The elements equal to 1 are not stored; the corresponding
array elements are modified but restored on exit. The rest of the
array is not used.
DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
( v1 1 ) ( 1 v2 v2 v2 )
( v1 v2 1 ) ( 1 v3 v3 )
( v1 v2 v3 )
( v1 v2 v3 )
DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
V = ( v1 v2 v3 ) V = ( v1 v1 1 )
( v1 v2 v3 ) ( v2 v2 v2 1 )
( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
( 1 v3 )
( 1 )
=====================================================================
Quick return if possible
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b2 = {0.,0.};
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
static integer i, j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
ztrmv_(char *, char *, char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *),
zlacgv_(integer *, doublecomplex *, integer *);
static doublecomplex vii;
#define TAU(I) tau[(I)-1]
#define V(I,J) v[(I)-1 + ((J)-1)* ( *ldv)]
#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F")) {
i__1 = *k;
for (i = 1; i <= *k; ++i) {
i__2 = i;
if (TAU(i).r == 0. && TAU(i).i == 0.) {
/* H(i) = I */
i__2 = i;
for (j = 1; j <= i; ++j) {
i__3 = j + i * t_dim1;
T(j,i).r = 0., T(j,i).i = 0.;
/* L10: */
}
} else {
/* general case */
i__2 = i + i * v_dim1;
vii.r = V(i,i).r, vii.i = V(i,i).i;
i__2 = i + i * v_dim1;
V(i,i).r = 1., V(i,i).i = 0.;
if (lsame_(storev, "C")) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)'
* V(i:n,i) */
i__2 = *n - i + 1;
i__3 = i - 1;
i__4 = i;
z__1.r = -TAU(i).r, z__1.i = -TAU(i).i;
zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &V(i,1), ldv, &V(i,i), &c__1, &c_b2, &
T(1,i), &c__1);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) *
V(i,i:n)' */
if (i < *n) {
i__2 = *n - i;
zlacgv_(&i__2, &V(i,i+1), ldv);
}
i__2 = i - 1;
i__3 = *n - i + 1;
i__4 = i;
z__1.r = -TAU(i).r, z__1.i = -TAU(i).i;
zgemv_("No transpose", &i__2, &i__3, &z__1, &V(1,i), ldv, &V(i,i), ldv, &c_b2, &T(1,i), &c__1);
if (i < *n) {
i__2 = *n - i;
zlacgv_(&i__2, &V(i,i+1), ldv);
}
}
i__2 = i + i * v_dim1;
V(i,i).r = vii.r, V(i,i).i = vii.i;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i - 1;
ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &T(1,1), ldt, &T(1,i), &c__1);
i__2 = i + i * t_dim1;
i__3 = i;
T(i,i).r = TAU(i).r, T(i,i).i = TAU(i).i;
}
/* L20: */
}
} else {
for (i = *k; i >= 1; --i) {
i__1 = i;
if (TAU(i).r == 0. && TAU(i).i == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i; j <= *k; ++j) {
i__2 = j + i * t_dim1;
T(j,i).r = 0., T(j,i).i = 0.;
/* L30: */
}
} else {
/* general case */
if (i < *k) {
if (lsame_(storev, "C")) {
i__1 = *n - *k + i + i * v_dim1;
vii.r = V(*n-*k+i,i).r, vii.i = V(*n-*k+i,i).i;
i__1 = *n - *k + i + i * v_dim1;
V(*n-*k+i,i).r = 1., V(*n-*k+i,i).i = 0.;
/* T(i+1:k,i) :=
- tau(i) * V(1:n-k+i,i+1
:k)' * V(1:n-k+i,i) */
i__1 = *n - *k + i;
i__2 = *k - i;
i__3 = i;
z__1.r = -TAU(i).r, z__1.i = -TAU(i).i;
zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &V(1,i+1), ldv, &V(1,i)
, &c__1, &c_b2, &T(i+1,i), &c__1);
i__1 = *n - *k + i + i * v_dim1;
V(*n-*k+i,i).r = vii.r, V(*n-*k+i,i).i = vii.i;
} else {
i__1 = i + (*n - *k + i) * v_dim1;
vii.r = V(i,*n-*k+i).r, vii.i = V(i,*n-*k+i).i;
i__1 = i + (*n - *k + i) * v_dim1;
V(i,*n-*k+i).r = 1., V(i,*n-*k+i).i = 0.;
/* T(i+1:k,i) :=
- tau(i) * V(i+1:k,1:n-k
+i) * V(i,1:n-k+i)' */
i__1 = *n - *k + i - 1;
zlacgv_(&i__1, &V(i,1), ldv);
i__1 = *k - i;
i__2 = *n - *k + i;
i__3 = i;
z__1.r = -TAU(i).r, z__1.i = -TAU(i).i;
zgemv_("No transpose", &i__1, &i__2, &z__1, &V(i+1,1), ldv, &V(i,1), ldv, &c_b2, &
T(i+1,i), &c__1);
i__1 = *n - *k + i - 1;
zlacgv_(&i__1, &V(i,1), ldv);
i__1 = i + (*n - *k + i) * v_dim1;
V(i,*n-*k+i).r = vii.r, V(i,*n-*k+i).i = vii.i;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,
i) */
i__1 = *k - i;
ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &T(i+1,i+1), ldt, &T(i+1,i)
, &c__1);
}
i__1 = i + i * t_dim1;
i__2 = i;
T(i,i).r = TAU(i).r, T(i,i).i = TAU(i).i;
}
/* L40: */
}
}
return 0;
/* End of ZLARFT */
} /* zlarft_ */
/* Subroutine */ int zpotf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, 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
=======
ZPOTF2 computes the Cholesky factorization of a complex Hermitian
positive definite matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U'*U or A = L*L'.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
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, z__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal ajj;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = a_subscr(j, j);
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a_ref(1, j), &c__1, &a_ref(1, j), &c__1);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(1, j), &c__1);
i__2 = j - 1;
i__3 = *n - j;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__2, &i__3, &z__1, &a_ref(1, j + 1),
lda, &a_ref(1, j), &c__1, &c_b1, &a_ref(j, j + 1),
lda);
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(1, j), &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a_ref(j, j + 1), lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = a_subscr(j, j);
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a_ref(j, 1), lda, &a_ref(j, 1), lda);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(j, 1), lda);
i__2 = *n - j;
i__3 = j - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(j + 1, 1),
lda, &a_ref(j, 1), lda, &c_b1, &a_ref(j + 1, j), &
c__1);
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(j, 1), lda);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of ZPOTF2 */
} /* zpotf2_ */
/* Subroutine */ int zlauu2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* -- LAPACK auxiliary 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
=======
ZLAUU2 computes the product U * U' or L' * L, where the triangular
factor U or L is stored in the upper or lower triangular part of
the array A.
If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
overwriting the factor U in A.
If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
overwriting the factor L in A.
This is the unblocked form of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the triangular factor stored in the array A
is upper or lower triangular:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the triangular factor U or L. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the triangular factor U or L.
On exit, if UPLO = 'U', the upper triangle of A is
overwritten with the upper triangle of the product U * U';
if UPLO = 'L', the lower triangle of A is overwritten with
the lower triangle of the product L' * L.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
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;
/* Local variables */
static integer i__;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal aii;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLAUU2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a_ref(i__, i__ + 1), lda, &a_ref(i__,
i__ + 1), lda);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = aii, z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &c_b1, &a_ref(1, i__ + 1)
, lda, &a_ref(i__, i__ + 1), lda, &z__1, &a_ref(1,
i__), &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
} else {
zdscal_(&i__, &aii, &a_ref(1, i__), &c__1);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &c__1);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = aii, z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &z__1, &
a_ref(i__, 1), lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
} else {
zdscal_(&i__, &aii, &a_ref(i__, 1), lda);
}
/* L20: */
}
}
return 0;
/* End of ZLAUU2 */
} /* zlauu2_ */
/* Subroutine */ int zpotf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j;
doublereal ajj;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPOTF2 computes the Cholesky factorization of a complex Hermitian */
/* positive definite matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a[j * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1]
, &c__1);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
i__3 = *n - j;
z__1.r = -1., z__1.i = -0.;
zgemv_("Transpose", &i__2, &i__3, &z__1, &a[(j + 1) * a_dim1
+ 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (
j + 1) * a_dim1], lda);
i__2 = j - 1;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a[j + a_dim1], lda, &a[j + a_dim1], lda);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
i__3 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[j + 1 + a_dim1]
, lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j *
a_dim1], &c__1);
i__2 = j - 1;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of ZPOTF2 */
} /* zpotf2_ */
/* Subroutine */ int zpbtf2_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, integer *info)
{
/* -- LAPACK 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
=======
ZPBTF2 computes the Cholesky factorization of a complex Hermitian
positive definite band matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix, U' is the conjugate transpose
of U, and L is lower triangular.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of super-diagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U'*U or A = L*L' of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublereal c_b8 = -1.;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer j;
extern logical lsame_(char *, char *);
static logical upper;
static integer kn;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal ajj;
static integer kld;
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = max(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(*kd + 1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of row J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(*kd, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
zher_("Upper", &kn, &c_b8, &ab_ref(*kd, j + 1), &kld, &ab_ref(
*kd + 1, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of column J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(2, j), &c__1);
zher_("Lower", &kn, &c_b8, &ab_ref(2, j), &c__1, &ab_ref(1, j
+ 1), &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of ZPBTF2 */
} /* zpbtf2_ */
int zungl2_(int *m, int *n, int *k,
doublecomplex *a, int *lda, doublecomplex *tau, doublecomplex *
work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
int i__, j, l;
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *), zlarf_(char *, int *, int *,
doublecomplex *, int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *), xerbla_(char *, int *), zlacgv_(int *, doublecomplex *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, */
/* which is defined as the first m rows of a product of k elementary */
/* reflectors of order n */
/* Q = H(k)' . . . H(2)' H(1)' */
/* as returned by ZGELQF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. N >= M. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the i-th row must contain the vector which defines */
/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
/* by ZGELQF in the first k rows of its array argument A. */
/* On exit, the m by n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= MAX(1,M). */
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGELQF. */
/* WORK (workspace) COMPLEX*16 array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. 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 < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < MAX(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGL2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = *k + 1; l <= i__2; ++l) {
i__3 = l + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
if (j > *k && j <= *m) {
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
}
/* L20: */
}
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i)' to A(i:m,i:n) from the right */
if (i__ < *n) {
i__1 = *n - i__;
zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
if (i__ < *m) {
i__1 = i__ + i__ * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *m - i__;
i__2 = *n - i__ + 1;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
z__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
i__1 = *n - i__;
i__2 = i__;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zscal_(&i__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda);
i__1 = *n - i__;
zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
}
i__1 = i__ + i__ * a_dim1;
d_cnjg(&z__2, &tau[i__]);
z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Set A(i,1:i-1) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
i__2 = i__ + l * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of ZUNGL2 */
} /* zungl2_ */
/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, doublecomplex *v, integer
*ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *
ldc, doublecomplex *work, integer *ldwork)
{
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *);
integer lastc;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer lastv;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrmm_(char *, char *, char *, char *
, integer *, integer *, doublecomplex *, doublecomplex *, integer
*, doublecomplex *, integer *);
extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
;
extern integer ilazlr_(integer *, integer *, doublecomplex *, integer *);
char transt[1];
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFB applies a complex block reflector H or its transpose H' to a */
/* complex M-by-N matrix C, from either the left or the right. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply H or H' from the Left */
/* = 'R': apply H or H' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply H (No transpose) */
/* = 'C': apply H' (Conjugate transpose) */
/* DIRECT (input) CHARACTER*1 */
/* Indicates how H is formed from a product of elementary */
/* reflectors */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Indicates how the vectors which define the elementary */
/* reflectors are stored: */
/* = 'C': Columnwise */
/* = 'R': Rowwise */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* K (input) INTEGER */
/* The order of the matrix T (= the number of elementary */
/* reflectors whose product defines the block reflector). */
/* V (input) COMPLEX*16 array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
/* if STOREV = 'R', LDV >= K. */
/* T (input) COMPLEX*16 array, dimension (LDT,K) */
/* The triangular K-by-K matrix T in the representation of the */
/* block reflector. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* If SIDE = 'L', LDWORK >= max(1,N); */
/* if SIDE = 'R', LDWORK >= max(1,M). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (lsame_(trans, "N")) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(storev, "C")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 ) (first K rows) */
/* ( V2 ) */
/* where V1 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L10: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C2'*V2 */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k +
1 + v_dim1], ldv, &c_b1, &work[work_offset],
ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (*m > *k) {
/* C2 := C2 - V2 * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &
lastc, k, &z__1, &v[*k + 1 + v_dim1], ldv, &work[
work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1]
, ldc);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L20: */
}
/* L30: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L40: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C2 * V2 */
i__1 = lastv - *k;
zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1
+ v_dim1], ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (lastv > *k) {
/* C2 := C2 - W * V2' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &lastc, &
i__1, k, &z__1, &work[work_offset], ldwork, &v[*k
+ 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1
+ 1], ldc);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L50: */
}
/* L60: */
}
}
} else {
/* Let V = ( V1 ) */
/* ( V2 ) (last K rows) */
/* where V2 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
j * work_dim1 + 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L70: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1'*V1 */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (lastv > *k) {
/* C1 := C1 - V1 * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &
lastc, k, &z__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
work[work_offset], ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = lastv - *k + j + i__ * c_dim1;
i__4 = lastv - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L80: */
}
/* L90: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
&work[j * work_dim1 + 1], &c__1);
/* L100: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1 * V1 */
i__1 = lastv - *k;
zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (lastv > *k) {
/* C1 := C1 - W * V1' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &lastc, &
i__1, k, &z__1, &work[work_offset], ldwork, &v[
v_offset], ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
work[work_offset], ldwork);
/* C2 := C2 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (lastv - *k + j) * c_dim1;
i__4 = i__ + (lastv - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L110: */
}
/* L120: */
}
}
}
} else if (lsame_(storev, "R")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 V2 ) (V1: first K columns) */
/* where V1 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L130: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
if (lastv > *k) {
/* W := W + C2'*V2' */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", &
lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1],
ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (lastv > *k) {
/* C2 := C2 - V2' * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, &lastc, k, &z__1, &v[(*k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork, &c_b1, &c__[*k
+ 1 + c_dim1], ldc);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L140: */
}
/* L150: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L160: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
if (lastv > *k) {
/* W := W + C2 * V2' */
i__1 = lastv - *k;
zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[
(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (lastv > *k) {
/* C2 := C2 - W * V2 */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
z__1, &work[work_offset], ldwork, &v[(*k + 1) *
v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 +
1], ldc);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L170: */
}
/* L180: */
}
}
} else {
/* Let V = ( V1 V2 ) (V2: last K columns) */
/* where V2 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
j * work_dim1 + 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L190: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1'*V1' */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", &
lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[
v_offset], ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (lastv > *k) {
/* C1 := C1 - V1' * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, &lastc, k, &z__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = lastv - *k + j + i__ * c_dim1;
i__4 = lastv - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L200: */
}
/* L210: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
&work[j * work_dim1 + 1], &c__1);
/* L220: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1 * V1' */
i__1 = lastv - *k;
zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (lastv > *k) {
/* C1 := C1 - W * V1 */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
z__1, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (lastv - *k + j) * c_dim1;
i__4 = i__ + (lastv - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of ZLARFB */
} /* zlarfb_ */
/* Subroutine */ int zlatrz_(integer *m, integer *n, integer *l,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer *
, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), zlarfg_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *),
zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix */
/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means */
/* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary */
/* matrix and, R and A1 are M-by-M upper triangular matrices. */
/* 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. */
/* L (input) INTEGER */
/* The number of columns of the matrix A containing the */
/* meaningful part of the Householder vectors. N-M >= L >= 0. */
/* 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 N-L+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. */
/* WORK (workspace) COMPLEX*16 array, dimension (M) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), which 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 l element vector. tau and z( k ) */
/* are chosen to annihilate the elements of the kth row of A2. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A1. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
if (*m == 0) {
return 0;
} else 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: */
}
return 0;
}
for (i__ = *m; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* [ A(i,i) A(i,n-l+1:n) ] */
zlacgv_(l, &a[i__ + (*n - *l + 1) * a_dim1], lda);
d_cnjg(&z__1, &a[i__ + i__ * a_dim1]);
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *l + 1;
zlarfg_(&i__1, &alpha, &a[i__ + (*n - *l + 1) * a_dim1], lda, &tau[
i__]);
i__1 = i__;
d_cnjg(&z__1, &tau[i__]);
tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
/* Apply H(i) to A(1:i-1,i:n) from the right */
i__1 = i__ - 1;
i__2 = *n - i__ + 1;
d_cnjg(&z__1, &tau[i__]);
zlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
lda, &z__1, &a[i__ * a_dim1 + 1], lda, &work[1], (ftnlen)5);
i__1 = i__ + i__ * a_dim1;
d_cnjg(&z__1, &alpha);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L20: */
}
return 0;
/* End of ZLATRZ */
} /* zlatrz_ */
/* Subroutine */ int zhptrs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k;
doublereal s;
doublecomplex ak, bk;
integer kc, kp;
doublecomplex akm1, bkm1, akm1k;
extern logical lsame_(char *, char *);
doublecomplex denom;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *,
integer *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPTRS solves a system of linear equations A*X = B with a complex */
/* Hermitian matrix A stored in packed format using the factorization */
/* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**H; */
/* = 'L': Lower triangular, form is A = L*D*L**H. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZHPTRF, stored as a */
/* packed triangular matrix. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZHPTRF. */
/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ap;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
kc -= k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 1;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
--k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
i__1 = k - 2;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
i__1 = k - 2;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 2;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
z_div(&z__1, &ap[kc - 1], &akm1k);
akm1.r = z__1.r, akm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc + k - 1], &z__2);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = z__1.r, bkm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k - 1 + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L20: */
}
kc = kc - k + 1;
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(U'(K)), where U(K) is the transformation */
/* stored in column K of A. */
if (k > 1) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc += k;
++k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
if (k > 1) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc + k], &c__1, &c_b1, &b[k + 1 + b_dim1],
ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc = kc + (k << 1) + 1;
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
kc = kc + *n - k + 1;
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + 1;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc], &z__2);
akm1.r = z__1.r, akm1.i = z__1.i;
z_div(&z__1, &ap[kc + *n - k + 1], &akm1k);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bkm1.r = z__1.r, bkm1.i = z__1.i;
z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + 1 + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L70: */
}
kc = kc + (*n - k << 1) + 1;
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
kc -= *n - k + 1;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(L'(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k
- 1 + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc -= *n - k + 2;
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of ZHPTRS */
} /* zhptrs_ */
/* Subroutine */ int zlahr2_(integer *n, integer *k, integer *nb,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
integer *ldt, doublecomplex *y, integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
integer i__;
doublecomplex ei;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), 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 *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztrmm_(char *, char *, char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrmv_(char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
doublecomplex *, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an unitary similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by ZGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) COMPLEX*16 array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's ZLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
i__2 = *n - *k;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[*k + 1 +
i__ * a_dim1], &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
ztrmv_("Lower", "Conjugate transpose", "UNIT", &i__2, &a[*k + 1 +
a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
t[*nb * t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
ztrmv_("Upper", "Conjugate transpose", "NON-UNIT", &i__2, &t[
t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ztrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
a[i__2].r = ei.r, a[i__2].i = ei.i;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
zlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
i__2 = *k + i__ + i__ * a_dim1;
ei.r = a[i__2].r, ei.i = a[i__2].i;
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b2, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
i__ * t_dim1 + 1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
zscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
ztrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
a[i__1].r = ei.r, a[i__1].i = ei.i;
/* Compute Y(1:K,1:NB) */
zlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
ztrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b2, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
zgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b2, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b2,
&y[y_offset], ldy);
}
ztrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b2, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of ZLAHR2 */
} /* zlahr2_ */
/* Subroutine */ int zunml2_(char *side, char *trans, integer *m, integer *n,
integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
doublecomplex aii;
logical left;
doublecomplex taui;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNML2 overwrites the general complex m-by-n matrix C with */
/* Q * C if SIDE = 'L' and TRANS = 'N', or */
/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
/* C * Q if SIDE = 'R' and TRANS = 'N', or */
/* C * Q' if SIDE = 'R' and TRANS = 'C', */
/* where Q is a complex unitary matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(k)' . . . H(2)' H(1)' */
/* as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q' from the Left */
/* = 'R': apply Q or Q' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply Q (No transpose) */
/* = 'C': apply Q' (Conjugate transpose) */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* A (input) COMPLEX*16 array, dimension */
/* (LDA,M) if SIDE = 'L', */
/* (LDA,N) if SIDE = 'R' */
/* The i-th row must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* ZGELQF in the first k rows of its array argument A. */
/* A is modified by the routine but restored on exit. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,K). */
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGELQF. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the m-by-n matrix C. */
/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (N) if SIDE = 'L', */
/* (M) if SIDE = 'R' */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,*k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNML2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) or H(i)' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H(i) or H(i)' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H(i) or H(i)' */
if (notran) {
d_cnjg(&z__1, &tau[i__]);
taui.r = z__1.r, taui.i = z__1.i;
} else {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
}
if (i__ < nq) {
i__3 = nq - i__;
zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
}
i__3 = i__ + i__ * a_dim1;
aii.r = a[i__3].r, aii.i = a[i__3].i;
i__3 = i__ + i__ * a_dim1;
a[i__3].r = 1., a[i__3].i = 0.;
zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic +
jc * c_dim1], ldc, &work[1]);
i__3 = i__ + i__ * a_dim1;
a[i__3].r = aii.r, a[i__3].i = aii.i;
if (i__ < nq) {
i__3 = nq - i__;
zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
}
/* L10: */
}
return 0;
/* End of ZUNML2 */
} /* zunml2_ */
/* Subroutine */ int zgbtrs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv,
doublecomplex *b, integer *ldb, 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
=======
ZGBTRS solves a system of linear equations
A * X = B, A**T * X = B, or A**H * X = B
with a general band matrix A using the LU factorization computed
by ZGBTRF.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
AB (input) COMPLEX*16 array, dimension (LDAB,N)
Details of the LU factorization of the band matrix A, as
computed by ZGBTRF. U is stored as an upper triangular band
matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
the multipliers used during the factorization are stored in
rows KL+KU+2 to 2*KL+KU+1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= N, row i of the matrix was
interchanged with row IPIV(i).
B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, the solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Local variables */
static integer i__, j, l;
extern logical lsame_(char *, char *);
static logical lnoti;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztbsv_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer kd, lm;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static logical notran;
#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 ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
kd = *ku + *kl + 1;
lnoti = *kl > 0;
if (notran) {
/* Solve A*X = B.
Solve L*X = B, overwriting B with X.
L is represented as a product of permutations and unit lower
triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
where each transformation L(i) is a rank-one modification of
the identity matrix. */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
l = ipiv[j];
if (l != j) {
zswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
z__1.r = -1., z__1.i = 0.;
zgeru_(&lm, nrhs, &z__1, &ab_ref(kd + 1, j), &c__1, &b_ref(j,
1), ldb, &b_ref(j + 1, 1), ldb);
/* L10: */
}
}
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U*X = B, overwriting B with X. */
i__2 = *kl + *ku;
ztbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b_ref(1, i__), &c__1);
/* L20: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * X = B. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U**T * X = B, overwriting B with X. */
i__2 = *kl + *ku;
ztbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
ldab, &b_ref(1, i__), &c__1);
/* L30: */
}
/* Solve L**T * X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &lm, nrhs, &z__1, &b_ref(j + 1, 1), ldb, &
ab_ref(kd + 1, j), &c__1, &c_b1, &b_ref(j, 1), ldb);
l = ipiv[j];
if (l != j) {
zswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
/* L40: */
}
}
} else {
/* Solve A**H * X = B. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U**H * X = B, overwriting B with X. */
i__2 = *kl + *ku;
ztbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b_ref(1, i__), &c__1);
/* L50: */
}
/* Solve L**H * X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
zlacgv_(nrhs, &b_ref(j, 1), ldb);
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &lm, nrhs, &z__1, &b_ref(j + 1,
1), ldb, &ab_ref(kd + 1, j), &c__1, &c_b1, &b_ref(j,
1), ldb);
zlacgv_(nrhs, &b_ref(j, 1), ldb);
l = ipiv[j];
if (l != j) {
zswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
/* L60: */
}
}
}
return 0;
/* End of ZGBTRS */
} /* zgbtrs_ */
