int
f2c_ztrmm(char* side, char* uplo, char* trans, char* diag,
integer* M, integer* N,
doublecomplex* alpha,
doublecomplex* A, integer* lda,
doublecomplex* B, integer* ldb)
{
ztrmm_(side, uplo, trans, diag,
M, N, alpha, A, lda, B, ldb);
return 0;
}
/* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
doublecomplex *b, integer *ldb, integer *iseed, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
integer j;
char c1[1], c2[2];
integer mb, nx;
logical gen, tri, qrs, sym, band;
char diag[1];
logical tran;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhemm_(char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgbmv_(char *, integer *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhbmv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zsbmv_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), ztbmv_(char
*, char *, char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zhpmv_(
char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zspmv_(char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zsymm_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *
, doublecomplex *, integer *), xerbla_(
char *, integer *);
extern logical lsamen_(integer *, char *, char *);
logical notran;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlarnv_(integer *, integer *, integer *, doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARHS chooses a set of NRHS random solution vectors and sets */
/* up the right hand sides for the linear system */
/* op( A ) * X = B, */
/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
/* transpose of A). */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The type of the complex matrix A. PATH may be given in any */
/* combination of upper and lower case. Valid paths include */
/* xGE: General m x n matrix */
/* xGB: General banded matrix */
/* xPO: Hermitian positive definite, 2-D storage */
/* xPP: Hermitian positive definite packed */
/* xPB: Hermitian positive definite banded */
/* xHE: Hermitian indefinite, 2-D storage */
/* xHP: Hermitian indefinite packed */
/* xHB: Hermitian indefinite banded */
/* xSY: Symmetric indefinite, 2-D storage */
/* xSP: Symmetric indefinite packed */
/* xSB: Symmetric indefinite banded */
/* xTR: Triangular */
/* xTP: Triangular packed */
/* xTB: Triangular banded */
/* xQR: General m x n matrix */
/* xLQ: General m x n matrix */
/* xQL: General m x n matrix */
/* xRQ: General m x n matrix */
/* where the leading character indicates the precision. */
/* XTYPE (input) CHARACTER*1 */
/* Specifies how the exact solution X will be determined: */
/* = 'N': New solution; generate a random X. */
/* = 'C': Computed; use value of X on entry. */
/* UPLO (input) CHARACTER*1 */
/* Used only if A is symmetric or triangular; specifies whether */
/* the upper or lower triangular part of the matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Used only if A is nonsymmetric; specifies the operation */
/* applied to the matrix A. */
/* = 'N': B := A * X */
/* = 'T': B := A**T * X */
/* = 'C': B := A**H * X */
/* 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 */
/* Used only if A is a band matrix; specifies the number of */
/* subdiagonals of A if A is a general band matrix or if A is */
/* symmetric or triangular and UPLO = 'L'; specifies the number */
/* of superdiagonals of A if A is symmetric or triangular and */
/* UPLO = 'U'. 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* Used only if A is a general band matrix or if A is */
/* triangular. */
/* If PATH = xGB, specifies the number of superdiagonals of A, */
/* and 0 <= KU <= N-1. */
/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
/* matrix has unit diagonal: */
/* = 1: matrix has non-unit diagonal (default) */
/* = 2: matrix has unit diagonal */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors in the system A*X = B. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The test matrix whose type is given by PATH. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If PATH = xGB, LDA >= KL+KU+1. */
/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
/* Otherwise, LDA >= max(1,M). */
/* X (input or output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
/* the exact solution to the system of linear equations. */
/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
/* with random values. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
/* B (output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side vector(s) for the system of equations, */
/* computed from B = op(A) * X, where op(A) is determined by */
/* TRANS. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. If TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* ZLATMS). Modified on exit. */
/* 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 parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--iseed;
/* Function Body */
*info = 0;
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
tran = lsame_(trans, "T") || lsame_(trans, "C");
notran = ! tran;
gen = lsame_(path + 1, "G");
qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
"Q");
sym = lsame_(path + 1, "P") || lsame_(path + 1,
"S") || lsame_(path + 1, "H");
tri = lsame_(path + 1, "T");
band = lsame_(path + 2, "B");
if (! lsame_(c1, "Zomplex precision")) {
*info = -1;
} else if (! (lsame_(xtype, "N") || lsame_(xtype,
"C"))) {
*info = -2;
} else if ((sym || tri) && ! (lsame_(uplo, "U") ||
lsame_(uplo, "L"))) {
*info = -3;
} else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
*info = -4;
} else if (*m < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (band && *kl < 0) {
*info = -7;
} else if (band && *ku < 0) {
*info = -8;
} else if (*nrhs < 0) {
*info = -9;
} else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
kl + 1 || band && gen && *lda < *kl + *ku + 1) {
*info = -11;
} else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
*info = -13;
} else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLARHS", &i__1);
return 0;
}
/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
if (tran) {
nx = *m;
mb = *n;
} else {
nx = *n;
mb = *m;
}
if (! lsame_(xtype, "C")) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
/* L10: */
}
}
/* Multiply X by op( A ) using an appropriate */
/* matrix multiply routine. */
if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
"QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
lsamen_(&c__2, c2, "RQ")) {
/* General matrix */
zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
x_offset], ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
c__2, c2, "HE")) {
/* Hermitian matrix, 2-D storage */
zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "SY")) {
/* Symmetric matrix, 2-D storage */
zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L20: */
}
} else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
c__2, c2, "HB")) {
/* Hermitian matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L30: */
}
} else if (lsamen_(&c__2, c2, "SB")) {
/* Symmetric matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L40: */
}
} else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
c__2, c2, "HP")) {
/* Hermitian matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L50: */
}
} else if (lsamen_(&c__2, c2, "SP")) {
/* Symmetric matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L60: */
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrix. Note that for triangular matrices, */
/* KU = 1 => non-unit triangular */
/* KU = 2 => unit triangular */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular matrix, packed storage */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
c__1);
/* L70: */
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular matrix, banded storage */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ 1], &c__1);
/* L80: */
}
} else {
/* If none of the above, set INFO = -1 and return */
*info = -1;
i__1 = -(*info);
xerbla_("ZLARHS", &i__1);
}
return 0;
/* End of ZLARHS */
} /* zlarhs_ */
/* Subroutine */ int zhegvd_(integer *itype, char *jobz, char *uplo, integer *
n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
integer *lrwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer lopt;
extern logical lsame_(char *, char *);
integer lwmin;
char trans[1];
integer liopt;
logical upper;
integer lropt;
logical wantz;
extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
ztrsm_(char *, char *, char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), xerbla_(char *,
integer *), zheevd_(char *, char *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *, integer
*);
integer liwmin;
extern /* Subroutine */ int zhegst_(integer *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
integer lrwmin;
logical lquery;
extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
integer *, integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors */
/* of a complex generalized Hermitian-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
/* B are assumed to be Hermitian and B is also positive definite. */
/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* 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. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
/* matrix Z of eigenvectors. The eigenvectors are normalized */
/* as follows: */
/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
/* or the lower triangle (if UPLO='L') of A, including the */
/* diagonal, is destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
/* On entry, the Hermitian matrix B. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of B contains the */
/* upper triangular part of the matrix B. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of B contains */
/* the lower triangular part of the matrix B. */
/* On exit, if INFO <= N, the part of B containing the matrix is */
/* overwritten by the triangular factor U or L from the Cholesky */
/* factorization B = U**H*U or B = L*L**H. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. */
/* If N <= 1, LWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LWORK >= N + 1. */
/* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */
/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
/* LRWORK (input) INTEGER */
/* The dimension of the array RWORK. */
/* If N <= 1, LRWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If N <= 1, LIWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */
/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: ZPOTRF or ZHEEVD returned an error code: */
/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */
/* failed to converge; i off-diagonal elements of an */
/* intermediate tridiagonal form did not converge to */
/* zero; */
/* if INFO = i and JOBZ = 'V', then the algorithm */
/* failed to compute an eigenvalue while working on */
/* the submatrix lying in rows and columns INFO/(N+1) */
/* through mod(INFO,N+1); */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* Modified so that no backsubstitution is performed if ZHEEVD fails to */
/* converge (NEIG in old code could be greater than N causing out of */
/* bounds reference to A - reported by Ralf Meyer). Also corrected the */
/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
/* ===================================================================== */
/* .. 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;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
} else if (wantz) {
lwmin = (*n << 1) + *n * *n;
lrwmin = *n * 5 + 1 + (*n << 1) * *n;
liwmin = *n * 5 + 3;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info == 0) {
work[1].r = (doublereal) lopt, work[1].i = 0.;
rwork[1] = (doublereal) lropt;
iwork[1] = liopt;
if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -13;
} else if (*liwork < liwmin && ! lquery) {
*info = -15;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
zpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
zheevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[
1], lrwork, &iwork[1], liwork, info);
/* Computing MAX */
d__1 = (doublereal) lopt, d__2 = work[1].r;
lopt = (integer) max(d__1,d__2);
/* Computing MAX */
d__1 = (doublereal) lropt;
lropt = (integer) max(d__1,rwork[1]);
/* Computing MAX */
d__1 = (doublereal) liopt, d__2 = (doublereal) iwork[1];
liopt = (integer) max(d__1,d__2);
if (wantz && *info == 0) {
/* Backtransform eigenvectors to the original problem. */
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ztrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ztrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
ldb, &a[a_offset], lda);
}
}
work[1].r = (doublereal) lopt, work[1].i = 0.;
rwork[1] = (doublereal) lropt;
iwork[1] = liopt;
return 0;
/* End of ZHEGVD */
} /* zhegvd_ */
/* Subroutine */ int ztimb3_(char *line, integer *nm, integer *mval, integer *
nn, integer *nval, integer *nk, integer *kval, integer *nlda, integer
*ldaval, doublereal *timmin, doublecomplex *a, doublecomplex *b,
doublecomplex *c__, doublereal *reslts, integer *ldr1, integer *ldr2,
integer *nout, ftnlen line_len)
{
/* Initialized data */
static char names[6*9] = "ZGEMM " "ZHEMM " "ZSYMM " "ZHERK " "ZHER2K"
"ZSYRK " "ZSYR2K" "ZTRMM " "ZTRSM ";
static char trans[1*3] = "N" "T" "C";
static char sides[1*2] = "L" "R";
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9997[] = "(5x,\002with LDA = \002,i5)";
static char fmt_9996[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9995[] = "(/1x,\002ZGEMM with TRANSA = '\002,a1,\002', "
"TRANSB = '\002,a1,\002'\002)";
static char fmt_9994[] = "(/1x,\002K = \002,i4,/)";
static char fmt_9993[] = "(/1x,a6,\002 with SIDE = '\002,a1,\002', UPLO "
"= '\002,a1,\002'\002,/)";
static char fmt_9992[] = "(/1x,a6,\002 with UPLO = '\002,a1,\002', TRANS"
" = '\002,a1,\002'\002,/)";
static char fmt_9991[] = "(/1x,a6,\002 with SIDE = '\002,a1,\002', UPLO "
"= '\002,a1,\002',\002,\002 TRANS = '\002,a1,\002'\002,/)";
static char fmt_9990[] = "(/////)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_offset, i__1, i__2, i__3, i__4;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer ilda;
static char side[1];
static integer imat, info;
static char path[3];
static doublereal time;
static integer isub;
static char uplo[1];
static integer i__, k, m, n;
static char cname[6];
static integer iside;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhemm_(char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
static integer iuplo;
static doublereal s1, s2;
extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zsymm_(char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *),
ztrsm_(char *, char *, char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), zsyrk_(char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, integer *);
extern doublereal dopbl3_(char *, integer *, integer *, integer *)
;
extern /* Subroutine */ int zher2k_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *);
static integer ic, ik, im, in;
extern doublereal dsecnd_(void);
extern /* Subroutine */ int zsyr2k_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), atimck_(integer *, char *, integer *, integer *, integer
*, integer *, integer *, integer *, ftnlen);
extern doublereal dmflop_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), dprtbl_(
char *, char *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *, ftnlen,
ftnlen);
static char transa[1], transb[1];
static doublereal untime;
static logical timsub[9];
extern /* Subroutine */ int ztimmg_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, integer *);
static integer lda, icl, ita, itb;
static doublereal ops;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9990, 0 };
#define names_ref(a_0,a_1) &names[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3) reslts[((a_3)*reslts_dim2 + (a_2))*\
reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTIMB3 times the Level 3 BLAS routines.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NK (input) INTEGER
The number of values of K contained in the vector KVAL.
KVAL (input) INTEGER array, dimension (NK)
The values of K. K is used as the intermediate matrix
dimension for ZGEMM (the product of an M x K matrix and a
K x N matrix) and as the dimension of the rank-K update in
ZHERK and ZSYRK.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) DOUBLE PRECISION
The minimum time a subroutine will be timed.
A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values permitted
for LDA and N.
B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
C (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA)
The timing results for each subroutine over the relevant
values of M, N, K, and LDA.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NM,NK).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NN).
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--kval;
--ldaval;
--a;
--b;
--c__;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * 1);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "B3", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__9, names, timsub, nout, &info, (ftnlen)3,
line_len, (ftnlen)6);
if (info != 0) {
goto L690;
}
/* Check that M <= LDA. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__1, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L690;
}
/* Time each routine. */
for (isub = 1; isub <= 9; ++isub) {
if (! timsub[isub - 1]) {
goto L680;
}
/* Print header. */
s_copy(cname, names_ref(0, isub), (ftnlen)6, (ftnlen)6);
io___11.ciunit = *nout;
s_wsfe(&io___11);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
if (*nlda == 1) {
io___12.ciunit = *nout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&ldaval[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L10: */
}
}
/* Time ZGEMM */
if (s_cmp(cname, "ZGEMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[ita - 1];
for (itb = 1; itb <= 3; ++itb) {
*(unsigned char *)transb = *(unsigned char *)&trans[itb -
1];
i__1 = *nk;
for (ik = 1; ik <= i__1; ++ik) {
k = kval[ik];
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
i__3 = *nm;
for (im = 1; im <= i__3; ++im) {
m = mval[im];
i__4 = *nn;
for (in = 1; in <= i__4; ++in) {
n = nval[in];
if (*(unsigned char *)transa == 'N') {
ztimmg_(&c__1, &m, &k, &a[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&c__1, &k, &m, &a[1], &lda, &
c__0, &c__0);
}
if (*(unsigned char *)transb == 'N') {
ztimmg_(&c__0, &k, &n, &b[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&c__0, &n, &k, &b[1], &lda, &
c__0, &c__0);
}
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L20:
zgemm_(transa, transb, &m, &n, &k, &c_b1,
&a[1], &lda, &b[1], &lda, &c_b1, &
c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda,
&c__0, &c__0);
goto L20;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L30:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda,
&c__0, &c__0);
goto L30;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &m, &n, &k);
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L40: */
}
/* L50: */
}
/* L60: */
}
if (ik == 1) {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, transa, (ftnlen)1);
do_fio(&c__1, transb, (ftnlen)1);
e_wsfe();
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&kval[ik], (ftnlen)sizeof(
integer));
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Time ZHEMM */
} else if (s_cmp(cname, "ZHEMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 6;
} else {
imat = -6;
}
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ztimmg_(&imat, &n, &n, &a[1], &lda, &c__0,
&c__0);
}
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = dsecnd_();
L100:
zhemm_(side, uplo, &m, &n, &c_b1, &a[1], &lda,
&b[1], &lda, &c_b1, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L100;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L110:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L110;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4)
;
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L120: */
}
/* L130: */
}
/* L140: */
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "ZHEMM ", (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (ftnlen)
1, (ftnlen)1);
/* L150: */
}
/* L160: */
}
/* Time ZSYMM */
} else if (s_cmp(cname, "ZSYMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 8;
} else {
imat = -8;
}
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ztimmg_(&imat, &n, &n, &a[1], &lda, &c__0,
&c__0);
}
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = dsecnd_();
L170:
zsymm_(side, uplo, &m, &n, &c_b1, &a[1], &lda,
&b[1], &lda, &c_b1, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L170;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L180:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L180;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4)
;
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L190: */
}
/* L200: */
}
/* L210: */
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "ZSYMM ", (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (ftnlen)
1, (ftnlen)1);
/* L220: */
}
/* L230: */
}
/* Time ZHERK */
} else if (s_cmp(cname, "ZHERK ", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 6;
} else {
imat = -6;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[ita -
1];
if (*(unsigned char *)transa != 'T') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transa == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L240:
zherk_(uplo, transa, &n, &k, &c_b156, &a[
1], &lda, &c_b156, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L240;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L250:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L250;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L260: */
}
/* L270: */
}
/* L280: */
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L290: */
}
/* L300: */
}
/* Time ZHER2K */
} else if (s_cmp(cname, "ZHER2K", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 6;
} else {
imat = -6;
}
for (itb = 1; itb <= 3; ++itb) {
*(unsigned char *)transb = *(unsigned char *)&trans[itb -
1];
if (*(unsigned char *)transb != 'T') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transb == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &n, &k, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &k, &n, &b[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L310:
zher2k_(uplo, transb, &n, &k, &c_b1, &a[1]
, &lda, &b[1], &lda, &c_b156, &
c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L310;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L320:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L320;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L330: */
}
/* L340: */
}
/* L350: */
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transb, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L360: */
}
/* L370: */
}
/* Time ZSYRK */
} else if (s_cmp(cname, "ZSYRK ", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 8;
} else {
imat = -8;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[ita -
1];
if (*(unsigned char *)transa != 'C') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transa == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L380:
zsyrk_(uplo, transa, &n, &k, &c_b1, &a[1],
&lda, &c_b1, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L380;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L390:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L390;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L400: */
}
/* L410: */
}
/* L420: */
}
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L430: */
}
/* L440: */
}
/* Time ZSYR2K */
} else if (s_cmp(cname, "ZSYR2K", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 8;
} else {
imat = -8;
}
for (itb = 1; itb <= 3; ++itb) {
*(unsigned char *)transb = *(unsigned char *)&trans[itb -
1];
if (*(unsigned char *)transb != 'C') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transb == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &n, &k, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &k, &n, &b[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L450:
zsyr2k_(uplo, transb, &n, &k, &c_b1, &a[1]
, &lda, &b[1], &lda, &c_b1, &c__[
1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L450;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L460:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L460;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L470: */
}
/* L480: */
}
/* L490: */
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transb, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L500: */
}
/* L510: */
}
/* Time ZTRMM */
} else if (s_cmp(cname, "ZTRMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 11;
} else {
imat = -11;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[
ita - 1];
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&imat, &n, &n, &a[1], &lda, &
c__0, &c__0);
}
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ic = 0;
s1 = dsecnd_();
L520:
ztrmm_(side, uplo, transa, "Non-unit", &m,
&n, &c_b1, &a[1], &lda, &b[1], &
lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L520;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L530:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L530;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4);
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L540: */
}
/* L550: */
}
/* L560: */
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
/* L570: */
}
/* L580: */
}
/* L590: */
}
/* Time ZTRSM */
} else if (s_cmp(cname, "ZTRSM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 11;
} else {
imat = -11;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[
ita - 1];
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&imat, &n, &n, &a[1], &lda, &
c__0, &c__0);
}
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ic = 0;
s1 = dsecnd_();
L600:
ztrsm_(side, uplo, transa, "Non-unit", &m,
&n, &c_b1, &a[1], &lda, &b[1], &
lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L600;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L610:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L610;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4);
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L620: */
}
/* L630: */
}
/* L640: */
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
/* L650: */
}
/* L660: */
}
/* L670: */
}
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
e_wsfe();
L680:
;
}
L690:
return 0;
/* End of ZTIMB3 */
} /* ztimb3_ */
/* Subroutine */ int zlauum_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, ib, nb;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zlauu2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAUUM 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 blocked form of the algorithm, calling Level 3 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 */
/* ===================================================================== */
/* .. 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_("ZLAUUM", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
zlauu2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
ztrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", &
i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
* a_dim1 + 1], lda);
zlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
zgemm_("No transpose", "Conjugate transpose", &i__3, &ib,
&i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, &
a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ *
a_dim1 + 1], lda);
i__3 = *n - i__ - ib + 1;
zherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[
i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ +
i__ * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
ztrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", &
ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
+ a_dim1], lda);
zlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
zgemm_("Conjugate transpose", "No transpose", &ib, &i__3,
&i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, &
a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1]
, lda);
i__3 = *n - i__ - ib + 1;
zherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21,
&a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__
+ i__ * a_dim1], lda);
}
/* L20: */
}
}
}
return 0;
/* End of ZLAUUM */
} /* zlauum_ */
/* 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 *);
extern /* Subroutine */
int zgemm_(char *, char *, integer *, 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 *), zlacgv_(integer *, doublecomplex *, integer *);
char transt[1];
/* -- LAPACK auxiliary routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* June 2013 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. 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**H * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) */
/* W := C1**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L10: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*m > *k)
{
/* W := W + C2**H * V2 */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "No transpose", n, 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**H or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W**H */
if (*m > *k)
{
/* C2 := C2 - V2 * W**H */
i__1 = *m - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("No transpose", "Conjugate transpose", &i__1, n, k, &z__1, &v[*k + 1 + v_dim1], ldv, &work[ work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1] , ldc);
}
/* W := W * V1**H */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* L20: */
}
/* L30: */
}
}
else if (lsame_(side, "R"))
{
/* Form C * H or C * H**H where C = ( C1 C2 ) */
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1);
/* L40: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*n > *k)
{
/* W := W + C2 * V2 */
i__1 = *n - *k;
zgemm_("No transpose", "No transpose", m, 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**H */
ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V**H */
if (*n > *k)
{
/* C2 := C2 - W * V2**H */
i__1 = *n - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("No transpose", "Conjugate transpose", m, &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**H */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, 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 = *m;
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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* 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**H * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) */
/* W := C2**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L70: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork);
if (*m > *k)
{
/* W := W + C1**H * V1 */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "No transpose", n, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b1, &work[work_offset], ldwork);
}
/* W := W * T**H or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W**H */
if (*m > *k)
{
/* C1 := C1 - V1 * W**H */
i__1 = *m - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("No transpose", "Conjugate transpose", &i__1, n, k, &z__1, &v[v_offset], ldv, &work[work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2**H */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, &c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[ work_offset], ldwork);
/* C2 := C2 - W**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = *m - *k + j + i__ * c_dim1;
i__4 = *m - *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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* L80: */
}
/* L90: */
}
}
else if (lsame_(side, "R"))
{
/* Form C * H or C * H**H where C = ( C1 C2 ) */
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ j * work_dim1 + 1], &c__1);
/* L100: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork);
if (*n > *k)
{
/* W := W + C1 * V1 */
i__1 = *n - *k;
zgemm_("No transpose", "No transpose", m, 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**H */
ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V**H */
if (*n > *k)
{
/* C1 := C1 - W * V1**H */
i__1 = *n - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("No transpose", "Conjugate transpose", m, &i__1, k, &z__1, &work[work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2**H */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, &c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[ work_offset], ldwork);
/* C2 := C2 - W */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + (*n - *k + j) * c_dim1;
i__4 = i__ + (*n - *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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* 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**H * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) */
/* W := C1**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L130: */
}
/* W := W * V1**H */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*m > *k)
{
/* W := W + C2**H * V2**H */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", n, 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**H or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V**H * W**H */
if (*m > *k)
{
/* C2 := C2 - V2**H * W**H */
i__1 = *m - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("Conjugate transpose", "Conjugate transpose", & i__1, n, 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", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* L140: */
}
/* L150: */
}
}
else if (lsame_(side, "R"))
{
/* Form C * H or C * H**H where C = ( C1 C2 ) */
/* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1);
/* L160: */
}
/* W := W * V1**H */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*n > *k)
{
/* W := W + C2 * V2**H */
i__1 = *n - *k;
zgemm_("No transpose", "Conjugate transpose", m, 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**H */
ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (*n > *k)
{
/* C2 := C2 - W * V2 */
i__1 = *n - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("No transpose", "No transpose", m, &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", m, 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 = *m;
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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* 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**H * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) */
/* W := C2**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
zlacgv_(n, &work[j * work_dim1 + 1], &c__1);
/* L190: */
}
/* W := W * V2**H */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, &c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork);
if (*m > *k)
{
/* W := W + C1**H * V1**H */
i__1 = *m - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", n, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T**H or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V**H * W**H */
if (*m > *k)
{
/* C1 := C1 - V1**H * W**H */
i__1 = *m - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("Conjugate transpose", "Conjugate transpose", & i__1, n, 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", n, k, &c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork);
/* C2 := C2 - W**H */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = *m - *k + j + i__ * c_dim1;
i__4 = *m - *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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* L200: */
}
/* L210: */
}
}
else if (lsame_(side, "R"))
{
/* Form C * H or C * H**H where C = ( C1 C2 ) */
/* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1;
j <= i__1;
++j)
{
zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ j * work_dim1 + 1], &c__1);
/* L220: */
}
/* W := W * V2**H */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k, &c_b1, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork);
if (*n > *k)
{
/* W := W + C1 * V1**H */
i__1 = *n - *k;
zgemm_("No transpose", "Conjugate transpose", m, 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**H */
ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (*n > *k)
{
/* C1 := C1 - W * V1 */
i__1 = *n - *k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemm_("No transpose", "No transpose", m, &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", m, k, &c_b1, &v[(*n - *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 = *m;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + (*n - *k + j) * c_dim1;
i__4 = i__ + (*n - *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; // , expr subst
c__[i__3].r = z__1.r;
c__[i__3].i = z__1.i; // , expr subst
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of ZLARFB */
}
/* Subroutine */
int zhegv_(integer *itype, char *jobz, char *uplo, integer * n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, neig;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int zheev_(char *, char *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *, doublereal *, integer *);
char trans[1];
logical upper, wantz;
extern /* Subroutine */
int ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int zhegst_(integer *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int zpotrf_(char *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. 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;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3)
{
*info = -1;
}
else if (! (wantz || lsame_(jobz, "N")))
{
*info = -2;
}
else if (! (upper || lsame_(uplo, "L")))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldb < max(1,*n))
{
*info = -8;
}
if (*info == 0)
{
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1;
i__2 = (nb + 1) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
/* Computing MAX */
i__1 = 1;
i__2 = (*n << 1) - 1; // , expr subst
if (*lwork < max(i__1,i__2) && ! lquery)
{
*info = -11;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHEGV ", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Form a Cholesky factorization of B. */
zpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0)
{
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1] , info);
if (wantz)
{
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0)
{
neig = *info - 1;
}
if (*itype == 1 || *itype == 2)
{
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
*/
/* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y */
if (upper)
{
*(unsigned char *)trans = 'N';
}
else
{
*(unsigned char *)trans = 'C';
}
ztrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[ b_offset], ldb, &a[a_offset], lda);
}
else if (*itype == 3)
{
/* For B*A*x=(lambda)*x;
*/
/* backtransform eigenvectors: x = L*y or U**H *y */
if (upper)
{
*(unsigned char *)trans = 'C';
}
else
{
*(unsigned char *)trans = 'N';
}
ztrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[ b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZHEGV */
}
/* 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 zneupd_(logical *rvec, char *howmny, logical *select,
doublecomplex *d__, doublecomplex *z__, integer *ldz, doublecomplex *
sigma, doublecomplex *workev, char *bmat, integer *n, char *which,
integer *nev, doublereal *tol, doublecomplex *resid, integer *ncv,
doublecomplex *v, integer *ldv, integer *iparam, integer *ipntr,
doublecomplex *workd, doublecomplex *workl, integer *lworkl,
doublereal *rwork, integer *info, ftnlen howmny_len, ftnlen bmat_len,
ftnlen which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer j, k, ih, jj, iq, np;
static doublecomplex vl[1];
static integer wr, ibd, ldh, ldq;
static doublereal sep;
static integer irz, mode;
static doublereal eps23;
static integer ierr;
static doublecomplex temp;
static integer iwev;
static char type__[6];
static integer ritz, iheig, ihbds;
static doublereal conds;
static logical reord;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer nconv;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal rtemp;
static doublecomplex rnorm;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ivout_(integer *, integer
*, integer *, integer *, char *, ftnlen), ztrmm_(char *, char *,
char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen), zmout_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(
integer *, integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *, ftnlen);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen);
static integer bounds, invsub, iuptri, msglvl, outncv, numcnv, ishift;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlahqr_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *), zngets_(integer *, char *
, integer *, integer *, doublecomplex *, doublecomplex *, ftnlen),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, ftnlen), ztrsen_(
char *, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *, integer *,
ftnlen, ftnlen), ztrevc_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublecomplex *,
doublereal *, integer *, ftnlen, ftnlen), zdscal_(integer *,
doublereal *, doublecomplex *, integer *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
--workd;
--resid;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--rwork;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mceupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
eps23 = pow_dd(&eps23, &c_b5);
/* %-------------------------------% */
/* | Quick return | */
/* | Check for incompatible input | */
/* %-------------------------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + (*ncv << 2)) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, WORKEV, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | */
/* | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by ZNEUPD. | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | */
/* | Ritz values. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | error bounds of | */
/* | the Ritz values | */
/* | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | */
/* | triangular matrix | */
/* | for H. | */
/* | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | */
/* | associated matrix | */
/* | representation of | */
/* | the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritz = ipntr[6];
iq = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheig = bounds + ldh;
ihbds = iheig + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheig;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wr = 1;
iwev = wr + *ncv;
/* %-----------------------------------------% */
/* | irz points to the Ritz values computed | */
/* | by _neigh before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irz = ipntr[14] + *ncv * *ncv;
ibd = irz + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
i__1 = ih + 2;
rnorm.r = workl[i__1].r, rnorm.i = workl[i__1].i;
i__1 = ih + 2;
workl[i__1].r = 0., workl[i__1].i = 0.;
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neupd: "
"Ritz values passed in from _NAUPD.", (ftnlen)42);
zvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
i__2 = bounds + j - 1;
workl[i__2].r = (doublereal) j, workl[i__2].i = 0.;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(ibd) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
zngets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], (
ftnlen)2);
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neu"
"pd: Ritz values after calling _NGETS.", (ftnlen)41);
zvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = irz + *ncv - j;
d__3 = workl[i__2].r;
d__4 = d_imag(&workl[irz + *ncv - j]);
d__1 = eps23, d__2 = dlapy2_(&d__3, &d__4);
rtemp = max(d__1,d__2);
i__2 = bounds + *ncv - j;
jj = (integer) workl[i__2].r;
i__2 = ibd + jj - 1;
d__1 = workl[i__2].r;
d__2 = d_imag(&workl[ibd + jj - 1]);
if (numcnv < nconv && dlapy2_(&d__1, &d__2) <= *tol * rtemp) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-------------------------------------------------------% */
/* | Call LAPACK routine zlahqr to compute the Schur form | */
/* | of the upper Hessenberg matrix returned by ZNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-------------------------------------------------------% */
i__1 = ldh * *ncv;
zcopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
zlaset_("All", ncv, ncv, &c_b2, &c_b1, &workl[invsub], &ldq, (ftnlen)
3);
zlahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheig], &c__1, ncv, &workl[invsub], &ldq, &ierr);
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H", (ftnlen)24);
zvout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper triangular matrix "
, (ftnlen)36);
}
}
if (reord) {
/* %-----------------------------------------------% */
/* | Reorder the computed upper triangular matrix. | */
/* %-----------------------------------------------% */
ztrsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheig], &nconv, &conds, &sep,
&workev[1], ncv, &ierr, (ftnlen)4, (ftnlen)1);
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H--reordered", (ftnlen)35);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Triangular matrix after"
" re-ordering", (ftnlen)43);
}
}
}
/* %---------------------------------------------% */
/* | Copy the last row of the Schur basis matrix | */
/* | to workl(ihbds). This vector will be used | */
/* | to compute the Ritz estimates of converged | */
/* | Ritz values. | */
/* %---------------------------------------------% */
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %--------------------------------------------% */
/* | Place the computed eigenvalues of H into D | */
/* | if a spectral transformation was not used. | */
/* %--------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
zcopy_(&nconv, &workl[iheig], &c__1, &d__[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
zgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %--------------------------------------------------------% */
/* | * Postmultiply V by Q using zunm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheig). The first NCONV | */
/* | columns of V are now approximate Schur vectors | */
/* | associated with the upper triangular matrix of order | */
/* | NCONV in workl(iuptri). | */
/* %--------------------------------------------------------% */
zunm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
zlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | triangular form of workl(iuptri,ldq). | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones. | */
/* %---------------------------------------------------% */
i__2 = invsub + (j - 1) * ldq + j - 1;
if (workl[i__2].r < 0.) {
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + j - 1], &ldq);
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
ztrevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&rwork[1], &ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | ztrevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
rtemp = dznrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
rtemp = 1. / rtemp;
zdscal_(ncv, &rtemp, &workl[invsub + (j - 1) * ldq], &c__1);
/* %------------------------------------------% */
/* | Ritz estimates can be obtained by taking | */
/* | the inner product of the last row of the | */
/* | Schur basis of H with eigenvectors of T. | */
/* | Note that the eigenvector matrix of T is | */
/* | upper triangular, thus the length of the | */
/* | inner product can be set to j. | */
/* %------------------------------------------% */
i__2 = j;
zdotc_(&z__1, &j, &workl[ihbds], &c__1, &workl[invsub + (j -
1) * ldq], &c__1);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
/* L40: */
}
if (msglvl > 2) {
zcopy_(&nconv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds],
&c__1);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Last row of the eigenvector"
" matrix for T", (ftnlen)48);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
zcopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %----------------------------------------------% */
/* | The eigenvector matrix Q of T is triangular. | */
/* | Form Z*Q. | */
/* %----------------------------------------------% */
ztrmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b1, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %--------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed ZNAUPD into D. | */
/* %--------------------------------------------------% */
zcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
zcopy_(&nconv, &workl[ritz], &c__1, &workl[iheig], &c__1);
zcopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
i__2 = iheig + k - 1;
temp.r = workl[i__2].r, temp.i = workl[i__2].i;
i__2 = ihbds + k - 1;
z_div(&z__2, &workl[ihbds + k - 1], &temp);
z_div(&z__1, &z__2, &temp);
workl[i__2].r = z__1.r, workl[i__2].i = z__1.i;
/* L50: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = nconv;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
z_div(&z__2, &c_b1, &workl[iheig + k - 1]);
z__1.r = z__2.r + sigma->r, z__1.i = z__2.i + sigma->i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
/* L60: */
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: U"
"ntransformed Ritz values.", (ftnlen)34);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of the untransformed Ritz values.", (
ftnlen)56);
} else if (msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: C"
"onverged Ritz values.", (ftnlen)30);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 3. See reference 3. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
i__2 = iheig + j - 1;
if (workl[i__2].r != 0. || workl[i__2].i != 0.) {
i__2 = j;
z_div(&z__1, &workl[invsub + (j - 1) * ldq + *ncv - 1], &
workl[iheig + j - 1]);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
}
/* L100: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
zgeru_(n, &nconv, &c_b1, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of zneupd| */
/* %---------------% */
} /* zneupd_ */
int main( int argc, char** argv )
{
obj_t a, b, c;
obj_t x, y;
obj_t alpha, beta;
dim_t m;
num_t dt_a, dt_b, dt_c;
num_t dt_alpha, dt_beta;
int ii;
#ifdef NBLIS
bli_init();
#endif
m = 4000;
dt_a = BLIS_DOUBLE;
dt_b = BLIS_DOUBLE;
dt_c = BLIS_DOUBLE;
dt_alpha = BLIS_DOUBLE;
dt_beta = BLIS_DOUBLE;
{
#ifdef NBLIS
bli_obj_create( dt_alpha, 1, 1, 0, 0, &alpha );
bli_obj_create( dt_beta, 1, 1, 0, 0, &beta );
bli_obj_create( dt_a, m, 1, 0, 0, &x );
bli_obj_create( dt_a, m, 1, 0, 0, &y );
bli_obj_create( dt_a, m, m, 0, 0, &a );
bli_obj_create( dt_b, m, m, 0, 0, &b );
bli_obj_create( dt_c, m, m, 0, 0, &c );
bli_randm( &a );
bli_randm( &b );
bli_randm( &c );
bli_setsc( (2.0/1.0), 0.0, &alpha );
bli_setsc( -(1.0/1.0), 0.0, &beta );
#endif
#ifdef NBLAS
x.buffer = malloc( m * 1 * sizeof( double ) );
y.buffer = malloc( m * 1 * sizeof( double ) );
alpha.buffer = malloc( 1 * sizeof( double ) );
beta.buffer = malloc( 1 * sizeof( double ) );
a.buffer = malloc( m * m * sizeof( double ) );
a.m = m;
a.n = m;
a.cs = m;
b.buffer = malloc( m * m * sizeof( double ) );
b.m = m;
b.n = m;
b.cs = m;
c.buffer = malloc( m * m * sizeof( double ) );
c.m = m;
c.n = m;
c.cs = m;
*((double*)alpha.buffer) = 2.0;
*((double*)beta.buffer) = -1.0;
#endif
#ifdef NBLIS
#if NBLIS >= 1
for ( ii = 0; ii < 2000000000; ++ii )
{
bli_gemm( &BLIS_ONE,
&a,
&b,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 2
{
bli_hemm( BLIS_LEFT,
&BLIS_ONE,
&a,
&b,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 3
{
bli_herk( &BLIS_ONE,
&a,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 4
{
bli_her2k( &BLIS_ONE,
&a,
&b,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 5
{
bli_trmm( BLIS_LEFT,
&BLIS_ONE,
&a,
&c );
}
#endif
#if NBLIS >= 6
{
bli_trsm( BLIS_LEFT,
&BLIS_ONE,
&a,
&c );
}
#endif
#endif
#ifdef NBLAS
#if NBLAS >= 1
for ( ii = 0; ii < 2000000000; ++ii )
{
f77_char transa = 'N';
f77_char transb = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dgemm_( &transa,
&transb,
&mm,
&nn,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 2
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dsymm_( &side,
&uplo,
&mm,
&nn,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 3
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dsyrk_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 4
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dsyr2k_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 5
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* cp = bli_obj_buffer( c );
dtrmm_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#if NBLAS >= 6
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* cp = bli_obj_buffer( c );
dtrsm_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#if NBLAS >= 7
{
f77_char transa = 'N';
f77_char transb = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* bp = bli_obj_buffer( b );
dcomplex* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zgemm_( &transa,
&transb,
&mm,
&nn,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 8
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* bp = bli_obj_buffer( b );
dcomplex* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zhemm_( &side,
&uplo,
&mm,
&nn,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 9
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
double* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zherk_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 10
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zher2k_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 11
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* cp = bli_obj_buffer( c );
ztrmm_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#if NBLAS >= 12
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* cp = bli_obj_buffer( c );
ztrsm_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#endif
#ifdef NBLIS
bli_obj_free( &x );
bli_obj_free( &y );
bli_obj_free( &alpha );
bli_obj_free( &beta );
bli_obj_free( &a );
bli_obj_free( &b );
bli_obj_free( &c );
#endif
#ifdef NBLAS
free( x.buffer );
free( y.buffer );
free( alpha.buffer );
free( beta.buffer );
free( a.buffer );
free( b.buffer );
free( c.buffer );
#endif
}
#ifdef NBLIS
bli_finalize();
#endif
return 0;
}
/* Subroutine */ int zhegv_(integer *itype, char *jobz, char *uplo, integer *
n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZHEGV computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
Here A and B are assumed to be Hermitian and B is also
positive definite.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
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. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
matrix Z of eigenvectors. The eigenvectors are normalized
as follows:
if ITYPE = 1 or 2, Z**H*B*Z = I;
if ITYPE = 3, Z**H*inv(B)*Z = I.
If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
or the lower triangle (if UPLO='L') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX*16 array, dimension (LDB, N)
On entry, the Hermitian positive definite matrix B.
If UPLO = 'U', the leading N-by-N upper triangular part of B
contains the upper triangular part of the matrix B.
If UPLO = 'L', the leading N-by-N lower triangular part of B
contains the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**H*U or B = L*L**H.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for ZHETRD returned by ILAENV.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: ZPOTRF or ZHEEV returned an error code:
<= N: if INFO = i, ZHEEV failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer neig;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zheev_(char *, char *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, integer *);
static char trans[1];
static logical upper, wantz;
extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
ztrsm_(char *, char *, char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer nb;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zhegst_(integer *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
integer *, integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -11;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 1) * *n;
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
zpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
, info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ztrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ztrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZHEGV */
} /* zhegv_ */
/* Subroutine */ int zlarzb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, integer *l, 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;
/* Local variables */
integer i__, j, info;
char transt[1];
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLARZB applies a complex block reflector H or its transpose H**H */
/* to a complex distributed M-by-N C from the left or the right. */
/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
/* 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, not supported yet) */
/* = '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 (not supported yet) */
/* = '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). */
/* L (input) INTEGER */
/* The number of columns of the matrix V containing the */
/* meaningful part of the Householder reflectors. */
/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
/* V (input) COMPLEX*16 array, dimension (LDV,NV). */
/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= L; 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). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* ===================================================================== */
/* 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;
}
/* Check for currently supported options */
info = 0;
if (! lsame_(direct, "B")) {
info = -3;
} else if (! lsame_(storev, "R")) {
info = -4;
}
if (info != 0) {
i__1 = -info;
xerbla_("ZLARZB", &i__1);
return 0;
}
if (lsame_(trans, "N")) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(side, "L")) {
/* Form H * C or H' * C */
/* W( 1:n, 1:k ) = conjg( C( 1:k, 1:n )' ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
}
/* conjg( C( m-l+1:m, 1:n )' ) * V( 1:k, 1:l )' */
if (*l > 0) {
zgemm_("Transpose", "Conjugate transpose", n, k, l, &c_b1, &c__[*
m - *l + 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b1, &
work[work_offset], ldwork);
}
/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */
ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[t_offset]
, ldt, &work[work_offset], ldwork);
/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - conjg( W( 1:n, 1:k )' ) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = j + i__ * 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;
}
}
/* conjg( V( 1:k, 1:l )' ) * conjg( W( 1:n, 1:k )' ) */
if (*l > 0) {
z__1.r = -1., z__1.i = -0.;
zgemm_("Transpose", "Transpose", l, n, k, &z__1, &v[v_offset],
ldv, &work[work_offset], ldwork, &c_b1, &c__[*m - *l + 1
+ c_dim1], ldc);
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' */
/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
c__1);
}
/* C( 1:m, n-l+1:n ) * conjg( V( 1:k, 1:l )' ) */
if (*l > 0) {
zgemm_("No transpose", "Transpose", m, k, l, &c_b1, &c__[(*n - *l
+ 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b1, &work[
work_offset], ldwork);
}
/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T ) or */
/* W( 1:m, 1:k ) * conjg( T' ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k - j + 1;
zlacgv_(&i__2, &t[j + j * t_dim1], &c__1);
}
ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[t_offset],
ldt, &work[work_offset], ldwork);
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k - j + 1;
zlacgv_(&i__2, &t[j + j * t_dim1], &c__1);
}
/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
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;
}
}
/* W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) ) */
i__1 = *l;
for (j = 1; j <= i__1; ++j) {
zlacgv_(k, &v[j * v_dim1 + 1], &c__1);
}
if (*l > 0) {
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", m, l, k, &z__1, &work[
work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[(*n
- *l + 1) * c_dim1 + 1], ldc);
}
i__1 = *l;
for (j = 1; j <= i__1; ++j) {
zlacgv_(k, &v[j * v_dim1 + 1], &c__1);
}
}
return 0;
/* End of ZLARZB */
} /* zlarzb_ */
int zhegst_(int *itype, char *uplo, int *n,
doublecomplex *a, int *lda, doublecomplex *b, int *ldb,
int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Local variables */
int k, kb, nb;
extern int lsame_(char *, char *);
extern int zhemm_(char *, char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *);
int upper;
extern int ztrmm_(char *, char *, char *, char *,
int *, int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *),
ztrsm_(char *, char *, char *, char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *), zhegs2_(int *,
char *, int *, doublecomplex *, int *, doublecomplex *,
int *, int *), zher2k_(char *, char *, int *,
int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *, double *, doublecomplex *,
int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHEGST 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**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* 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**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by ZPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* 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_("ZHEGST", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZHEGST", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
zhegs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
} else {
/* Use blocked code */
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
i__2 = nb;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = MIN(i__3,nb);
/* Update the upper triangle of A(k:n,k:n) */
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
if (k + kb <= *n) {
i__3 = *n - k - kb + 1;
ztrsm_("Left", uplo, "Conjugate transpose", "Non-unit"
, &kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb,
&a[k + (k + kb) * a_dim1], lda);
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_("Left", uplo, &kb, &i__3, &z__1, &a[k + k *
a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
&c_b1, &a[k + (k + kb) * a_dim1], lda);
i__3 = *n - k - kb + 1;
z__1.r = -1., z__1.i = -0.;
zher2k_(uplo, "Conjugate transpose", &i__3, &kb, &
z__1, &a[k + (k + kb) * a_dim1], lda, &b[k + (
k + kb) * b_dim1], ldb, &c_b18, &a[k + kb + (
k + kb) * a_dim1], lda)
;
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_("Left", uplo, &kb, &i__3, &z__1, &a[k + k *
a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
&c_b1, &a[k + (k + kb) * a_dim1], lda);
i__3 = *n - k - kb + 1;
ztrsm_("Right", uplo, "No transpose", "Non-unit", &kb,
&i__3, &c_b1, &b[k + kb + (k + kb) * b_dim1],
ldb, &a[k + (k + kb) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__2 = *n;
i__1 = nb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = MIN(i__3,nb);
/* Update the lower triangle of A(k:n,k:n) */
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
if (k + kb <= *n) {
i__3 = *n - k - kb + 1;
ztrsm_("Right", uplo, "Conjugate transpose", "Non-un"
"it", &i__3, &kb, &c_b1, &b[k + k * b_dim1],
ldb, &a[k + kb + k * a_dim1], lda);
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_("Right", uplo, &i__3, &kb, &z__1, &a[k + k *
a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
c_b1, &a[k + kb + k * a_dim1], lda);
i__3 = *n - k - kb + 1;
z__1.r = -1., z__1.i = -0.;
zher2k_(uplo, "No transpose", &i__3, &kb, &z__1, &a[k
+ kb + k * a_dim1], lda, &b[k + kb + k *
b_dim1], ldb, &c_b18, &a[k + kb + (k + kb) *
a_dim1], lda);
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_("Right", uplo, &i__3, &kb, &z__1, &a[k + k *
a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
c_b1, &a[k + kb + k * a_dim1], lda);
i__3 = *n - k - kb + 1;
ztrsm_("Left", uplo, "No transpose", "Non-unit", &
i__3, &kb, &c_b1, &b[k + kb + (k + kb) *
b_dim1], ldb, &a[k + kb + k * a_dim1], lda);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
i__2 = nb;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = MIN(i__3,nb);
/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */
i__3 = k - 1;
ztrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, &
kb, &c_b1, &b[b_offset], ldb, &a[k * a_dim1 + 1],
lda);
i__3 = k - 1;
zhemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
k * a_dim1 + 1], lda);
i__3 = k - 1;
zher2k_(uplo, "No transpose", &i__3, &kb, &c_b1, &a[k *
a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b18,
&a[a_offset], lda);
i__3 = k - 1;
zhemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
k * a_dim1 + 1], lda);
i__3 = k - 1;
ztrmm_("Right", uplo, "Conjugate transpose", "Non-unit", &
i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb, &a[k *
a_dim1 + 1], lda);
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
/* L30: */
}
} else {
/* Compute L'*A*L */
i__2 = *n;
i__1 = nb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = MIN(i__3,nb);
/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */
i__3 = k - 1;
ztrmm_("Right", uplo, "No transpose", "Non-unit", &kb, &
i__3, &c_b1, &b[b_offset], ldb, &a[k + a_dim1],
lda);
i__3 = k - 1;
zhemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
lda);
i__3 = k - 1;
zher2k_(uplo, "Conjugate transpose", &i__3, &kb, &c_b1, &
a[k + a_dim1], lda, &b[k + b_dim1], ldb, &c_b18, &
a[a_offset], lda);
i__3 = k - 1;
zhemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
lda);
i__3 = k - 1;
ztrmm_("Left", uplo, "Conjugate transpose", "Non-unit", &
kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb, &a[k +
a_dim1], lda);
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
/* L40: */
}
}
}
}
return 0;
/* End of ZHEGST */
} /* zhegst_ */
/* Subroutine */ int zpftri_(char *transr, char *uplo, integer *n,
doublecomplex *a, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer k, n1, n2;
logical normaltransr;
logical lower;
logical nisodd;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* Purpose */
/* ======= */
/* ZPFTRI computes the inverse of a complex Hermitian positive definite */
/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
/* computed by ZPFTRF. */
/* Arguments */
/* ========= */
/* TRANSR (input) CHARACTER */
/* = 'N': The Normal TRANSR of RFP A is stored; */
/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
/* UPLO (input) CHARACTER */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ); */
/* On entry, the Hermitian matrix A in RFP format. RFP format is */
/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
/* the Conjugate-transpose of RFP A as defined when */
/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
/* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
/* is odd. See the Note below for more details. */
/* On exit, the Hermitian inverse of the original matrix, in the */
/* same storage format. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
/* zero, and the inverse could not be computed. */
/* Note: */
/* ===== */
/* We first consider Standard Packed Format when N is even. */
/* We give an example where N = 6. */
/* AP is Upper AP is Lower */
/* 00 01 02 03 04 05 00 */
/* 11 12 13 14 15 10 11 */
/* 22 23 24 25 20 21 22 */
/* 33 34 35 30 31 32 33 */
/* 44 45 40 41 42 43 44 */
/* 55 50 51 52 53 54 55 */
/* Let TRANSR = 'N'. RFP holds AP as follows: */
/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
/* conjugate-transpose of the first three columns of AP upper. */
/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
/* conjugate-transpose of the last three columns of AP lower. */
/* To denote conjugate we place -- above the element. This covers the */
/* case N even and TRANSR = 'N'. */
/* RFP A RFP A */
/* -- -- -- */
/* 03 04 05 33 43 53 */
/* -- -- */
/* 13 14 15 00 44 54 */
/* -- */
/* 23 24 25 10 11 55 */
/* 33 34 35 20 21 22 */
/* -- */
/* 00 44 45 30 31 32 */
/* -- -- */
/* 01 11 55 40 41 42 */
/* -- -- -- */
/* 02 12 22 50 51 52 */
/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
/* transpose of RFP A above. One therefore gets: */
/* RFP A RFP A */
/* -- -- -- -- -- -- -- -- -- -- */
/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
/* -- -- -- -- -- -- -- -- -- -- */
/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
/* -- -- -- -- -- -- -- -- -- -- */
/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
/* We next consider Standard Packed Format when N is odd. */
/* We give an example where N = 5. */
/* AP is Upper AP is Lower */
/* 00 01 02 03 04 00 */
/* 11 12 13 14 10 11 */
/* 22 23 24 20 21 22 */
/* 33 34 30 31 32 33 */
/* 44 40 41 42 43 44 */
/* Let TRANSR = 'N'. RFP holds AP as follows: */
/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
/* conjugate-transpose of the first two columns of AP upper. */
/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
/* conjugate-transpose of the last two columns of AP lower. */
/* To denote conjugate we place -- above the element. This covers the */
/* case N odd and TRANSR = 'N'. */
/* RFP A RFP A */
/* -- -- */
/* 02 03 04 00 33 43 */
/* -- */
/* 12 13 14 10 11 44 */
/* 22 23 24 20 21 22 */
/* -- */
/* 00 33 34 30 31 32 */
/* -- -- */
/* 01 11 44 40 41 42 */
/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
/* transpose of RFP A above. One therefore gets: */
/* RFP A RFP A */
/* -- -- -- -- -- -- -- -- -- */
/* 02 12 22 00 01 00 10 20 30 40 50 */
/* -- -- -- -- -- -- -- -- -- */
/* 03 13 23 33 11 33 11 21 31 41 51 */
/* -- -- -- -- -- -- -- -- -- */
/* 04 14 24 34 44 43 44 22 32 42 52 */
/* ===================================================================== */
/* Test the input parameters. */
*info = 0;
normaltransr = lsame_(transr, "N");
lower = lsame_(uplo, "L");
if (! normaltransr && ! lsame_(transr, "C")) {
*info = -1;
} else if (! lower && ! lsame_(uplo, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPFTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
ztftri_(transr, uplo, "N", n, a, info);
if (*info > 0) {
return 0;
}
/* If N is odd, set NISODD = .TRUE. */
/* If N is even, set K = N/2 and NISODD = .FALSE. */
if (*n % 2 == 0) {
k = *n / 2;
nisodd = FALSE_;
} else {
nisodd = TRUE_;
}
/* Set N1 and N2 depending on LOWER */
if (lower) {
n2 = *n / 2;
n1 = *n - n2;
} else {
n1 = *n / 2;
n2 = *n - n1;
}
/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */
/* inv(L)^C*inv(L). There are eight cases. */
if (nisodd) {
/* N is odd */
if (normaltransr) {
/* N is odd and TRANSR = 'N' */
if (lower) {
/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */
/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */
/* T1 -> a(0), T2 -> a(n), S -> a(N1) */
zlauum_("L", &n1, a, n, info);
zherk_("L", "C", &n1, &n2, &c_b12, &a[n1], n, &c_b12, a, n);
ztrmm_("L", "U", "N", "N", &n2, &n1, &c_b1, &a[*n], n, &a[n1],
n);
zlauum_("U", &n2, &a[*n], n, info);
} else {
/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */
/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */
/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */
zlauum_("L", &n1, &a[n2], n, info);
zherk_("L", "N", &n1, &n2, &c_b12, a, n, &c_b12, &a[n2], n);
ztrmm_("R", "U", "C", "N", &n1, &n2, &c_b1, &a[n1], n, a, n);
zlauum_("U", &n2, &a[n1], n, info);
}
} else {
/* N is odd and TRANSR = 'C' */
if (lower) {
/* SRPA for LOWER, TRANSPOSE, and N is odd */
/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */
zlauum_("U", &n1, a, &n1, info);
zherk_("U", "N", &n1, &n2, &c_b12, &a[n1 * n1], &n1, &c_b12,
a, &n1);
ztrmm_("R", "L", "N", "N", &n1, &n2, &c_b1, &a[1], &n1, &a[n1
* n1], &n1);
zlauum_("L", &n2, &a[1], &n1, info);
} else {
/* SRPA for UPPER, TRANSPOSE, and N is odd */
/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */
zlauum_("U", &n1, &a[n2 * n2], &n2, info);
zherk_("U", "C", &n1, &n2, &c_b12, a, &n2, &c_b12, &a[n2 * n2]
, &n2);
ztrmm_("L", "L", "C", "N", &n2, &n1, &c_b1, &a[n1 * n2], &n2,
a, &n2);
zlauum_("L", &n2, &a[n1 * n2], &n2, info);
}
}
} else {
/* N is even */
if (normaltransr) {
/* N is even and TRANSR = 'N' */
if (lower) {
/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
i__1 = *n + 1;
zlauum_("L", &k, &a[1], &i__1, info);
i__1 = *n + 1;
i__2 = *n + 1;
zherk_("L", "C", &k, &k, &c_b12, &a[k + 1], &i__1, &c_b12, &a[
1], &i__2);
i__1 = *n + 1;
i__2 = *n + 1;
ztrmm_("L", "U", "N", "N", &k, &k, &c_b1, a, &i__1, &a[k + 1],
&i__2);
i__1 = *n + 1;
zlauum_("U", &k, a, &i__1, info);
} else {
/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
i__1 = *n + 1;
zlauum_("L", &k, &a[k + 1], &i__1, info);
i__1 = *n + 1;
i__2 = *n + 1;
zherk_("L", "N", &k, &k, &c_b12, a, &i__1, &c_b12, &a[k + 1],
&i__2);
i__1 = *n + 1;
i__2 = *n + 1;
ztrmm_("R", "U", "C", "N", &k, &k, &c_b1, &a[k], &i__1, a, &
i__2);
i__1 = *n + 1;
zlauum_("U", &k, &a[k], &i__1, info);
}
} else {
/* N is even and TRANSR = 'C' */
if (lower) {
/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */
/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */
/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
zlauum_("U", &k, &a[k], &k, info);
zherk_("U", "N", &k, &k, &c_b12, &a[k * (k + 1)], &k, &c_b12,
&a[k], &k);
ztrmm_("R", "L", "N", "N", &k, &k, &c_b1, a, &k, &a[k * (k +
1)], &k);
zlauum_("L", &k, a, &k, info);
} else {
/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */
/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */
/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
zlauum_("U", &k, &a[k * (k + 1)], &k, info);
zherk_("U", "C", &k, &k, &c_b12, a, &k, &c_b12, &a[k * (k + 1)
], &k);
ztrmm_("L", "L", "C", "N", &k, &k, &c_b1, &a[k * k], &k, a, &
k);
zlauum_("L", &k, &a[k * k], &k, info);
}
}
}
return 0;
/* End of ZPFTRI */
} /* zpftri_ */
/* Subroutine */ int zlaqr5_(logical *wantt, logical *wantz, integer *kacc22,
integer *n, integer *ktop, integer *kbot, integer *nshfts,
doublecomplex *s, doublecomplex *h__, integer *ldh, integer *iloz,
integer *ihiz, doublecomplex *z__, integer *ldz, doublecomplex *v,
integer *ldv, doublecomplex *u, integer *ldu, integer *nv,
doublecomplex *wv, integer *ldwv, integer *nh, doublecomplex *wh,
integer *ldwh)
{
/* System generated locals */
integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1,
wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
/* Local variables */
integer j, k, m, i2, j2, i4, j4, k1;
doublereal h11, h12, h21, h22;
integer m22, ns, nu;
doublecomplex vt[3];
doublereal scl;
integer kdu, kms;
doublereal ulp;
integer knz, kzs;
doublereal tst1, tst2;
doublecomplex beta;
logical blk22, bmp22;
integer mend, jcol, jlen, jbot, mbot, jtop, jrow, mtop;
doublecomplex alpha;
logical accum;
integer ndcol, incol, krcol, nbmps;
doublereal safmin, safmax;
doublecomplex refsum;
integer mstart;
doublereal smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* This auxiliary subroutine called by ZLAQR0 performs a */
/* single small-bulge multi-shift QR sweep. */
/* WANTT (input) logical scalar */
/* WANTT = .true. if the triangular Schur factor */
/* is being computed. WANTT is set to .false. otherwise. */
/* WANTZ (input) logical scalar */
/* WANTZ = .true. if the unitary Schur factor is being */
/* computed. WANTZ is set to .false. otherwise. */
/* KACC22 (input) integer with value 0, 1, or 2. */
/* Specifies the computation mode of far-from-diagonal */
/* orthogonal updates. */
/* = 0: ZLAQR5 does not accumulate reflections and does not */
/* use matrix-matrix multiply to update far-from-diagonal */
/* matrix entries. */
/* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix */
/* multiply to update the far-from-diagonal matrix entries. */
/* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix */
/* multiply to update the far-from-diagonal matrix entries, */
/* and takes advantage of 2-by-2 block structure during */
/* matrix multiplies. */
/* N (input) integer scalar */
/* N is the order of the Hessenberg matrix H upon which this */
/* subroutine operates. */
/* KTOP (input) integer scalar */
/* KBOT (input) integer scalar */
/* These are the first and last rows and columns of an */
/* isolated diagonal block upon which the QR sweep is to be */
/* applied. It is assumed without a check that */
/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */
/* and */
/* either KBOT = N or H(KBOT+1,KBOT) = 0. */
/* NSHFTS (input) integer scalar */
/* NSHFTS gives the number of simultaneous shifts. NSHFTS */
/* must be positive and even. */
/* S (input/output) COMPLEX*16 array of size (NSHFTS) */
/* S contains the shifts of origin that define the multi- */
/* shift QR sweep. On output S may be reordered. */
/* H (input/output) COMPLEX*16 array of size (LDH,N) */
/* On input H contains a Hessenberg matrix. On output a */
/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */
/* to the isolated diagonal block in rows and columns KTOP */
/* through KBOT. */
/* LDH (input) integer scalar */
/* LDH is the leading dimension of H just as declared in the */
/* calling procedure. LDH.GE.MAX(1,N). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* Z (input/output) COMPLEX*16 array of size (LDZ,IHI) */
/* If WANTZ = .TRUE., then the QR Sweep unitary */
/* similarity transformation is accumulated into */
/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ = .FALSE., then Z is unreferenced. */
/* LDZ (input) integer scalar */
/* LDA is the leading dimension of Z just as declared in */
/* the calling procedure. LDZ.GE.N. */
/* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) */
/* LDV (input) integer scalar */
/* LDV is the leading dimension of V as declared in the */
/* calling procedure. LDV.GE.3. */
/* U (workspace) COMPLEX*16 array of size */
/* (LDU,3*NSHFTS-3) */
/* LDU (input) integer scalar */
/* LDU is the leading dimension of U just as declared in the */
/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */
/* NH (input) integer scalar */
/* NH is the number of columns in array WH available for */
/* workspace. NH.GE.1. */
/* WH (workspace) COMPLEX*16 array of size (LDWH,NH) */
/* LDWH (input) integer scalar */
/* Leading dimension of WH just as declared in the */
/* calling procedure. LDWH.GE.3*NSHFTS-3. */
/* NV (input) integer scalar */
/* NV is the number of rows in WV agailable for workspace. */
/* NV.GE.1. */
/* WV (workspace) COMPLEX*16 array of size */
/* (LDWV,3*NSHFTS-3) */
/* LDWV (input) integer scalar */
/* LDWV is the leading dimension of WV as declared in the */
/* in the calling subroutine. LDWV.GE.NV. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* Reference: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and */
/* Level 3 Performance, SIAM Journal of Matrix Analysis, */
/* volume 23, pages 929--947, 2002. */
/* ================================================================ */
/* ==== If there are no shifts, then there is nothing to do. ==== */
/* Parameter adjustments */
--s;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
wh_dim1 = *ldwh;
wh_offset = 1 + wh_dim1;
wh -= wh_offset;
/* Function Body */
if (*nshfts < 2) {
return 0;
}
/* ==== If the active block is empty or 1-by-1, then there */
/* . is nothing to do. ==== */
if (*ktop >= *kbot) {
return 0;
}
/* ==== NSHFTS is supposed to be even, but if it is odd, */
/* . then simply reduce it by one. ==== */
ns = *nshfts - *nshfts % 2;
/* ==== Machine constants for deflation ==== */
safmin = dlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_("PRECISION");
smlnum = safmin * ((doublereal) (*n) / ulp);
/* ==== Use accumulated reflections to update far-from-diagonal */
/* . entries ? ==== */
accum = *kacc22 == 1 || *kacc22 == 2;
/* ==== If so, exploit the 2-by-2 block structure? ==== */
blk22 = ns > 2 && *kacc22 == 2;
/* ==== clear trash ==== */
if (*ktop + 2 <= *kbot) {
i__1 = *ktop + 2 + *ktop * h_dim1;
h__[i__1].r = 0., h__[i__1].i = 0.;
}
/* ==== NBMPS = number of 2-shift bulges in the chain ==== */
nbmps = ns / 2;
/* ==== KDU = width of slab ==== */
kdu = nbmps * 6 - 3;
/* ==== Create and chase chains of NBMPS bulges ==== */
i__1 = *kbot - 2;
i__2 = nbmps * 3 - 2;
for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 :
incol <= i__1; incol += i__2) {
ndcol = incol + kdu;
if (accum) {
zlaset_("ALL", &kdu, &kdu, &c_b1, &c_b2, &u[u_offset], ldu);
}
/* ==== Near-the-diagonal bulge chase. The following loop */
/* . performs the near-the-diagonal part of a small bulge */
/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */
/* . chunk extends from column INCOL to column NDCOL */
/* . (including both column INCOL and column NDCOL). The */
/* . following loop chases a 3*NBMPS column long chain of */
/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */
/* . may be less than KTOP and and NDCOL may be greater than */
/* . KBOT indicating phantom columns from which to chase */
/* . bulges before they are actually introduced or to which */
/* . to chase bulges beyond column KBOT.) ==== */
/* Computing MIN */
i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
i__3 = min(i__4,i__5);
for (krcol = incol; krcol <= i__3; ++krcol) {
/* ==== Bulges number MTOP to MBOT are active double implicit */
/* . shift bulges. There may or may not also be small */
/* . 2-by-2 bulge, if there is room. The inactive bulges */
/* . (if any) must wait until the active bulges have moved */
/* . down the diagonal to make room. The phantom matrix */
/* . paradigm described above helps keep track. ==== */
/* Computing MAX */
i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
mtop = max(i__4,i__5);
/* Computing MIN */
i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
mbot = min(i__4,i__5);
m22 = mbot + 1;
bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
/* ==== Generate reflections to chase the chain right */
/* . one column. (The minimum value of K is KTOP-1.) ==== */
i__4 = mbot;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
if (k == *ktop - 1) {
zlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &s[(m <<
1) - 1], &s[m * 2], &v[m * v_dim1 + 1]);
i__5 = m * v_dim1 + 1;
alpha.r = v[i__5].r, alpha.i = v[i__5].i;
zlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m *
v_dim1 + 1]);
} else {
i__5 = k + 1 + k * h_dim1;
beta.r = h__[i__5].r, beta.i = h__[i__5].i;
i__5 = m * v_dim1 + 2;
i__6 = k + 2 + k * h_dim1;
v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
i__5 = m * v_dim1 + 3;
i__6 = k + 3 + k * h_dim1;
v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
zlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m *
v_dim1 + 1]);
/* ==== A Bulge may collapse because of vigilant */
/* . deflation or destructive underflow. In the */
/* . underflow case, try the two-small-subdiagonals */
/* . trick to try to reinflate the bulge. ==== */
i__5 = k + 3 + k * h_dim1;
i__6 = k + 3 + (k + 1) * h_dim1;
i__7 = k + 3 + (k + 2) * h_dim1;
if (h__[i__5].r != 0. || h__[i__5].i != 0. || (h__[i__6]
.r != 0. || h__[i__6].i != 0.) || h__[i__7].r ==
0. && h__[i__7].i == 0.) {
/* ==== Typical case: not collapsed (yet). ==== */
i__5 = k + 1 + k * h_dim1;
h__[i__5].r = beta.r, h__[i__5].i = beta.i;
i__5 = k + 2 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = k + 3 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
} else {
/* ==== Atypical case: collapsed. Attempt to */
/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */
/* . If the fill resulting from the new */
/* . reflector is too large, then abandon it. */
/* . Otherwise, use the new one. ==== */
zlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &
s[(m << 1) - 1], &s[m * 2], vt);
alpha.r = vt[0].r, alpha.i = vt[0].i;
zlarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
d_cnjg(&z__2, vt);
i__5 = k + 1 + k * h_dim1;
d_cnjg(&z__5, &vt[1]);
i__6 = k + 2 + k * h_dim1;
z__4.r = z__5.r * h__[i__6].r - z__5.i * h__[i__6].i,
z__4.i = z__5.r * h__[i__6].i + z__5.i * h__[
i__6].r;
z__3.r = h__[i__5].r + z__4.r, z__3.i = h__[i__5].i +
z__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;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = k + 2 + k * h_dim1;
z__3.r = refsum.r * vt[1].r - refsum.i * vt[1].i,
z__3.i = refsum.r * vt[1].i + refsum.i * vt[1]
.r;
z__2.r = h__[i__5].r - z__3.r, z__2.i = h__[i__5].i -
z__3.i;
z__1.r = z__2.r, z__1.i = z__2.i;
z__5.r = refsum.r * vt[2].r - refsum.i * vt[2].i,
z__5.i = refsum.r * vt[2].i + refsum.i * vt[2]
.r;
z__4.r = z__5.r, z__4.i = z__5.i;
i__6 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
i__8 = k + 2 + (k + 2) * h_dim1;
if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1)
, abs(d__2)) + ((d__3 = z__4.r, abs(d__3)) + (
d__4 = d_imag(&z__4), abs(d__4))) > ulp * ((
d__5 = h__[i__6].r, abs(d__5)) + (d__6 =
d_imag(&h__[k + k * h_dim1]), abs(d__6)) + ((
d__7 = h__[i__7].r, abs(d__7)) + (d__8 =
d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
d__8))) + ((d__9 = h__[i__8].r, abs(d__9)) + (
d__10 = d_imag(&h__[k + 2 + (k + 2) * h_dim1])
, abs(d__10))))) {
/* ==== Starting a new bulge here would */
/* . create non-negligible fill. Use */
/* . the old one with trepidation. ==== */
i__5 = k + 1 + k * h_dim1;
h__[i__5].r = beta.r, h__[i__5].i = beta.i;
i__5 = k + 2 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = k + 3 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
} else {
/* ==== Stating a new bulge here would */
/* . create only negligible fill. */
/* . Replace the old reflector with */
/* . the new one. ==== */
i__5 = k + 1 + k * h_dim1;
i__6 = k + 1 + k * h_dim1;
z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[
i__6].i - refsum.i;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
i__5 = k + 2 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = k + 3 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
i__5 = m * v_dim1 + 1;
v[i__5].r = vt[0].r, v[i__5].i = vt[0].i;
i__5 = m * v_dim1 + 2;
v[i__5].r = vt[1].r, v[i__5].i = vt[1].i;
i__5 = m * v_dim1 + 3;
v[i__5].r = vt[2].r, v[i__5].i = vt[2].i;
}
}
}
}
/* ==== Generate a 2-by-2 reflection, if needed. ==== */
k = krcol + (m22 - 1) * 3;
if (bmp22) {
if (k == *ktop - 1) {
zlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &s[(
m22 << 1) - 1], &s[m22 * 2], &v[m22 * v_dim1 + 1])
;
i__4 = m22 * v_dim1 + 1;
beta.r = v[i__4].r, beta.i = v[i__4].i;
zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
* v_dim1 + 1]);
} else {
i__4 = k + 1 + k * h_dim1;
beta.r = h__[i__4].r, beta.i = h__[i__4].i;
i__4 = m22 * v_dim1 + 2;
i__5 = k + 2 + k * h_dim1;
v[i__4].r = h__[i__5].r, v[i__4].i = h__[i__5].i;
zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
* v_dim1 + 1]);
i__4 = k + 1 + k * h_dim1;
h__[i__4].r = beta.r, h__[i__4].i = beta.i;
i__4 = k + 2 + k * h_dim1;
h__[i__4].r = 0., h__[i__4].i = 0.;
}
}
/* ==== Multiply H by reflections from the left ==== */
if (accum) {
jbot = min(ndcol,*kbot);
} else if (*wantt) {
jbot = *n;
} else {
jbot = *kbot;
}
i__4 = jbot;
for (j = max(*ktop,krcol); j <= i__4; ++j) {
/* Computing MIN */
i__5 = mbot, i__6 = (j - krcol + 2) / 3;
mend = min(i__5,i__6);
i__5 = mend;
for (m = mtop; m <= i__5; ++m) {
k = krcol + (m - 1) * 3;
d_cnjg(&z__2, &v[m * v_dim1 + 1]);
i__6 = k + 1 + j * h_dim1;
d_cnjg(&z__6, &v[m * v_dim1 + 2]);
i__7 = k + 2 + j * h_dim1;
z__5.r = z__6.r * h__[i__7].r - z__6.i * h__[i__7].i,
z__5.i = z__6.r * h__[i__7].i + z__6.i * h__[i__7]
.r;
z__4.r = h__[i__6].r + z__5.r, z__4.i = h__[i__6].i +
z__5.i;
d_cnjg(&z__8, &v[m * v_dim1 + 3]);
i__8 = k + 3 + j * h_dim1;
z__7.r = z__8.r * h__[i__8].r - z__8.i * h__[i__8].i,
z__7.i = z__8.r * h__[i__8].i + z__8.i * h__[i__8]
.r;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.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;
refsum.r = z__1.r, refsum.i = z__1.i;
i__6 = k + 1 + j * h_dim1;
i__7 = k + 1 + j * h_dim1;
z__1.r = h__[i__7].r - refsum.r, z__1.i = h__[i__7].i -
refsum.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = k + 2 + j * h_dim1;
i__7 = k + 2 + j * h_dim1;
i__8 = m * v_dim1 + 2;
z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = k + 3 + j * h_dim1;
i__7 = k + 3 + j * h_dim1;
i__8 = m * v_dim1 + 3;
z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
}
}
if (bmp22) {
k = krcol + (m22 - 1) * 3;
/* Computing MAX */
i__4 = k + 1;
i__5 = jbot;
for (j = max(i__4,*ktop); j <= i__5; ++j) {
d_cnjg(&z__2, &v[m22 * v_dim1 + 1]);
i__4 = k + 1 + j * h_dim1;
d_cnjg(&z__5, &v[m22 * v_dim1 + 2]);
i__6 = k + 2 + j * h_dim1;
z__4.r = z__5.r * h__[i__6].r - z__5.i * h__[i__6].i,
z__4.i = z__5.r * h__[i__6].i + z__5.i * h__[i__6]
.r;
z__3.r = h__[i__4].r + z__4.r, z__3.i = h__[i__4].i +
z__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;
refsum.r = z__1.r, refsum.i = z__1.i;
i__4 = k + 1 + j * h_dim1;
i__6 = k + 1 + j * h_dim1;
z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[i__6].i -
refsum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = k + 2 + j * h_dim1;
i__6 = k + 2 + j * h_dim1;
i__7 = m22 * v_dim1 + 2;
z__2.r = refsum.r * v[i__7].r - refsum.i * v[i__7].i,
z__2.i = refsum.r * v[i__7].i + refsum.i * v[i__7]
.r;
z__1.r = h__[i__6].r - z__2.r, z__1.i = h__[i__6].i -
z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
}
}
/* ==== Multiply H by reflections from the right. */
/* . Delay filling in the last row until the */
/* . vigilant deflation check is complete. ==== */
if (accum) {
jtop = max(*ktop,incol);
} else if (*wantt) {
jtop = 1;
} else {
jtop = *ktop;
}
i__5 = mbot;
for (m = mtop; m <= i__5; ++m) {
i__4 = m * v_dim1 + 1;
if (v[i__4].r != 0. || v[i__4].i != 0.) {
k = krcol + (m - 1) * 3;
/* Computing MIN */
i__6 = *kbot, i__7 = k + 3;
i__4 = min(i__6,i__7);
for (j = jtop; j <= i__4; ++j) {
i__6 = m * v_dim1 + 1;
i__7 = j + (k + 1) * h_dim1;
i__8 = m * v_dim1 + 2;
i__9 = j + (k + 2) * h_dim1;
z__4.r = v[i__8].r * h__[i__9].r - v[i__8].i * h__[
i__9].i, z__4.i = v[i__8].r * h__[i__9].i + v[
i__8].i * h__[i__9].r;
z__3.r = h__[i__7].r + z__4.r, z__3.i = h__[i__7].i +
z__4.i;
i__10 = m * v_dim1 + 3;
i__11 = j + (k + 3) * h_dim1;
z__5.r = v[i__10].r * h__[i__11].r - v[i__10].i * h__[
i__11].i, z__5.i = v[i__10].r * h__[i__11].i
+ v[i__10].i * h__[i__11].r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__1.r = v[i__6].r * z__2.r - v[i__6].i * z__2.i,
z__1.i = v[i__6].r * z__2.i + v[i__6].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__6 = j + (k + 1) * h_dim1;
i__7 = j + (k + 1) * h_dim1;
z__1.r = h__[i__7].r - refsum.r, z__1.i = h__[i__7].i
- refsum.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = j + (k + 2) * h_dim1;
i__7 = j + (k + 2) * h_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
i__6 = j + (k + 3) * h_dim1;
i__7 = j + (k + 3) * h_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
z__2.i;
h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
}
if (accum) {
/* ==== Accumulate U. (If necessary, update Z later */
/* . with with an efficient matrix-matrix */
/* . multiply.) ==== */
kms = k - incol;
/* Computing MAX */
i__4 = 1, i__6 = *ktop - incol;
i__7 = kdu;
for (j = max(i__4,i__6); j <= i__7; ++j) {
i__4 = m * v_dim1 + 1;
i__6 = j + (kms + 1) * u_dim1;
i__8 = m * v_dim1 + 2;
i__9 = j + (kms + 2) * u_dim1;
z__4.r = v[i__8].r * u[i__9].r - v[i__8].i * u[
i__9].i, z__4.i = v[i__8].r * u[i__9].i +
v[i__8].i * u[i__9].r;
z__3.r = u[i__6].r + z__4.r, z__3.i = u[i__6].i +
z__4.i;
i__10 = m * v_dim1 + 3;
i__11 = j + (kms + 3) * u_dim1;
z__5.r = v[i__10].r * u[i__11].r - v[i__10].i * u[
i__11].i, z__5.i = v[i__10].r * u[i__11]
.i + v[i__10].i * u[i__11].r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i +
z__5.i;
z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i,
z__1.i = v[i__4].r * z__2.i + v[i__4].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__4 = j + (kms + 1) * u_dim1;
i__6 = j + (kms + 1) * u_dim1;
z__1.r = u[i__6].r - refsum.r, z__1.i = u[i__6].i
- refsum.i;
u[i__4].r = z__1.r, u[i__4].i = z__1.i;
i__4 = j + (kms + 2) * u_dim1;
i__6 = j + (kms + 2) * u_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = u[i__6].r - z__2.r, z__1.i = u[i__6].i -
z__2.i;
u[i__4].r = z__1.r, u[i__4].i = z__1.i;
i__4 = j + (kms + 3) * u_dim1;
i__6 = j + (kms + 3) * u_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = u[i__6].r - z__2.r, z__1.i = u[i__6].i -
z__2.i;
u[i__4].r = z__1.r, u[i__4].i = z__1.i;
}
} else if (*wantz) {
/* ==== U is not accumulated, so update Z */
/* . now by multiplying by reflections */
/* . from the right. ==== */
i__7 = *ihiz;
for (j = *iloz; j <= i__7; ++j) {
i__4 = m * v_dim1 + 1;
i__6 = j + (k + 1) * z_dim1;
i__8 = m * v_dim1 + 2;
i__9 = j + (k + 2) * z_dim1;
z__4.r = v[i__8].r * z__[i__9].r - v[i__8].i *
z__[i__9].i, z__4.i = v[i__8].r * z__[
i__9].i + v[i__8].i * z__[i__9].r;
z__3.r = z__[i__6].r + z__4.r, z__3.i = z__[i__6]
.i + z__4.i;
i__10 = m * v_dim1 + 3;
i__11 = j + (k + 3) * z_dim1;
z__5.r = v[i__10].r * z__[i__11].r - v[i__10].i *
z__[i__11].i, z__5.i = v[i__10].r * z__[
i__11].i + v[i__10].i * z__[i__11].r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i +
z__5.i;
z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i,
z__1.i = v[i__4].r * z__2.i + v[i__4].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__4 = j + (k + 1) * z_dim1;
i__6 = j + (k + 1) * z_dim1;
z__1.r = z__[i__6].r - refsum.r, z__1.i = z__[
i__6].i - refsum.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = j + (k + 2) * z_dim1;
i__6 = j + (k + 2) * z_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = z__[i__6].r - z__2.r, z__1.i = z__[i__6]
.i - z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = j + (k + 3) * z_dim1;
i__6 = j + (k + 3) * z_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = z__[i__6].r - z__2.r, z__1.i = z__[i__6]
.i - z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
}
}
}
}
/* ==== Special case: 2-by-2 reflection (if needed) ==== */
k = krcol + (m22 - 1) * 3;
i__5 = m22 * v_dim1 + 1;
if (bmp22 && (v[i__5].r != 0. || v[i__5].i != 0.)) {
/* Computing MIN */
i__7 = *kbot, i__4 = k + 3;
i__5 = min(i__7,i__4);
for (j = jtop; j <= i__5; ++j) {
i__7 = m22 * v_dim1 + 1;
i__4 = j + (k + 1) * h_dim1;
i__6 = m22 * v_dim1 + 2;
i__8 = j + (k + 2) * h_dim1;
z__3.r = v[i__6].r * h__[i__8].r - v[i__6].i * h__[i__8]
.i, z__3.i = v[i__6].r * h__[i__8].i + v[i__6].i *
h__[i__8].r;
z__2.r = h__[i__4].r + z__3.r, z__2.i = h__[i__4].i +
z__3.i;
z__1.r = v[i__7].r * z__2.r - v[i__7].i * z__2.i, z__1.i =
v[i__7].r * z__2.i + v[i__7].i * z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__7 = j + (k + 1) * h_dim1;
i__4 = j + (k + 1) * h_dim1;
z__1.r = h__[i__4].r - refsum.r, z__1.i = h__[i__4].i -
refsum.i;
h__[i__7].r = z__1.r, h__[i__7].i = z__1.i;
i__7 = j + (k + 2) * h_dim1;
i__4 = j + (k + 2) * h_dim1;
d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i =
refsum.r * z__3.i + refsum.i * z__3.r;
z__1.r = h__[i__4].r - z__2.r, z__1.i = h__[i__4].i -
z__2.i;
h__[i__7].r = z__1.r, h__[i__7].i = z__1.i;
}
if (accum) {
kms = k - incol;
/* Computing MAX */
i__5 = 1, i__7 = *ktop - incol;
i__4 = kdu;
for (j = max(i__5,i__7); j <= i__4; ++j) {
i__5 = m22 * v_dim1 + 1;
i__7 = j + (kms + 1) * u_dim1;
i__6 = m22 * v_dim1 + 2;
i__8 = j + (kms + 2) * u_dim1;
z__3.r = v[i__6].r * u[i__8].r - v[i__6].i * u[i__8]
.i, z__3.i = v[i__6].r * u[i__8].i + v[i__6]
.i * u[i__8].r;
z__2.r = u[i__7].r + z__3.r, z__2.i = u[i__7].i +
z__3.i;
z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i,
z__1.i = v[i__5].r * z__2.i + v[i__5].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = j + (kms + 1) * u_dim1;
i__7 = j + (kms + 1) * u_dim1;
z__1.r = u[i__7].r - refsum.r, z__1.i = u[i__7].i -
refsum.i;
u[i__5].r = z__1.r, u[i__5].i = z__1.i;
i__5 = j + (kms + 2) * u_dim1;
i__7 = j + (kms + 2) * u_dim1;
d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = u[i__7].r - z__2.r, z__1.i = u[i__7].i -
z__2.i;
u[i__5].r = z__1.r, u[i__5].i = z__1.i;
}
} else if (*wantz) {
i__4 = *ihiz;
for (j = *iloz; j <= i__4; ++j) {
i__5 = m22 * v_dim1 + 1;
i__7 = j + (k + 1) * z_dim1;
i__6 = m22 * v_dim1 + 2;
i__8 = j + (k + 2) * z_dim1;
z__3.r = v[i__6].r * z__[i__8].r - v[i__6].i * z__[
i__8].i, z__3.i = v[i__6].r * z__[i__8].i + v[
i__6].i * z__[i__8].r;
z__2.r = z__[i__7].r + z__3.r, z__2.i = z__[i__7].i +
z__3.i;
z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i,
z__1.i = v[i__5].r * z__2.i + v[i__5].i *
z__2.r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = j + (k + 1) * z_dim1;
i__7 = j + (k + 1) * z_dim1;
z__1.r = z__[i__7].r - refsum.r, z__1.i = z__[i__7].i
- refsum.i;
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
i__5 = j + (k + 2) * z_dim1;
i__7 = j + (k + 2) * z_dim1;
d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
z__2.i = refsum.r * z__3.i + refsum.i *
z__3.r;
z__1.r = z__[i__7].r - z__2.r, z__1.i = z__[i__7].i -
z__2.i;
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
}
}
}
/* ==== Vigilant deflation check ==== */
mstart = mtop;
if (krcol + (mstart - 1) * 3 < *ktop) {
++mstart;
}
mend = mbot;
if (bmp22) {
++mend;
}
if (krcol == *kbot - 2) {
++mend;
}
i__4 = mend;
for (m = mstart; m <= i__4; ++m) {
/* Computing MIN */
i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
k = min(i__5,i__7);
/* ==== The following convergence test requires that */
/* . the tradition small-compared-to-nearby-diagonals */
/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */
/* . criteria both be satisfied. The latter improves */
/* . accuracy in some examples. Falling back on an */
/* . alternate convergence criterion when TST1 or TST2 */
/* . is zero (as done here) is traditional but probably */
/* . unnecessary. ==== */
i__5 = k + 1 + k * h_dim1;
if (h__[i__5].r != 0. || h__[i__5].i != 0.) {
i__5 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
tst1 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&
h__[k + k * h_dim1]), abs(d__2)) + ((d__3 = h__[
i__7].r, abs(d__3)) + (d__4 = d_imag(&h__[k + 1 +
(k + 1) * h_dim1]), abs(d__4)));
if (tst1 == 0.) {
if (k >= *ktop + 1) {
i__5 = k + (k - 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + (k - 1) * h_dim1]), abs(
d__2));
}
if (k >= *ktop + 2) {
i__5 = k + (k - 2) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + (k - 2) * h_dim1]), abs(
d__2));
}
if (k >= *ktop + 3) {
i__5 = k + (k - 3) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + (k - 3) * h_dim1]), abs(
d__2));
}
if (k <= *kbot - 2) {
i__5 = k + 2 + (k + 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 2 + (k + 1) * h_dim1]),
abs(d__2));
}
if (k <= *kbot - 3) {
i__5 = k + 3 + (k + 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 3 + (k + 1) * h_dim1]),
abs(d__2));
}
if (k <= *kbot - 4) {
i__5 = k + 4 + (k + 1) * h_dim1;
tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 4 + (k + 1) * h_dim1]),
abs(d__2));
}
}
i__5 = k + 1 + k * h_dim1;
/* Computing MAX */
d__3 = smlnum, d__4 = ulp * tst1;
if ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&h__[
k + 1 + k * h_dim1]), abs(d__2)) <= max(d__3,d__4)
) {
/* Computing MAX */
i__5 = k + 1 + k * h_dim1;
i__7 = k + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)),
d__6 = (d__3 = h__[i__7].r, abs(d__3)) + (
d__4 = d_imag(&h__[k + (k + 1) * h_dim1]),
abs(d__4));
h12 = max(d__5,d__6);
/* Computing MIN */
i__5 = k + 1 + k * h_dim1;
i__7 = k + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)),
d__6 = (d__3 = h__[i__7].r, abs(d__3)) + (
d__4 = d_imag(&h__[k + (k + 1) * h_dim1]),
abs(d__4));
h21 = min(d__5,d__6);
i__5 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
z__2.r = h__[i__5].r - h__[i__7].r, z__2.i = h__[i__5]
.i - h__[i__7].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
i__6 = k + 1 + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + (
d__4 = d_imag(&z__1), abs(d__4));
h11 = max(d__5,d__6);
i__5 = k + k * h_dim1;
i__7 = k + 1 + (k + 1) * h_dim1;
z__2.r = h__[i__5].r - h__[i__7].r, z__2.i = h__[i__5]
.i - h__[i__7].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MIN */
i__6 = k + 1 + (k + 1) * h_dim1;
d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 =
d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + (
d__4 = d_imag(&z__1), abs(d__4));
h22 = min(d__5,d__6);
scl = h11 + h12;
tst2 = h22 * (h11 / scl);
/* Computing MAX */
d__1 = smlnum, d__2 = ulp * tst2;
if (tst2 == 0. || h21 * (h12 / scl) <= max(d__1,d__2))
{
i__5 = k + 1 + k * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
}
}
}
}
/* ==== Fill in the last row of each bulge. ==== */
/* Computing MIN */
i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
mend = min(i__4,i__5);
i__4 = mend;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
i__5 = m * v_dim1 + 1;
i__7 = m * v_dim1 + 3;
z__2.r = v[i__5].r * v[i__7].r - v[i__5].i * v[i__7].i,
z__2.i = v[i__5].r * v[i__7].i + v[i__5].i * v[i__7]
.r;
i__6 = k + 4 + (k + 3) * h_dim1;
z__1.r = z__2.r * h__[i__6].r - z__2.i * h__[i__6].i, z__1.i =
z__2.r * h__[i__6].i + z__2.i * h__[i__6].r;
refsum.r = z__1.r, refsum.i = z__1.i;
i__5 = k + 4 + (k + 1) * h_dim1;
z__1.r = -refsum.r, z__1.i = -refsum.i;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
i__5 = k + 4 + (k + 2) * h_dim1;
z__2.r = -refsum.r, z__2.i = -refsum.i;
d_cnjg(&z__3, &v[m * v_dim1 + 2]);
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;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
i__5 = k + 4 + (k + 3) * h_dim1;
i__7 = k + 4 + (k + 3) * h_dim1;
d_cnjg(&z__3, &v[m * v_dim1 + 3]);
z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i =
refsum.r * z__3.i + refsum.i * z__3.r;
z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i - z__2.i;
h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
}
/* ==== End of near-the-diagonal bulge chase. ==== */
}
/* ==== Use U (if accumulated) to update far-from-diagonal */
/* . entries in H. If required, use U to update Z as */
/* . well. ==== */
if (accum) {
if (*wantt) {
jtop = 1;
jbot = *n;
} else {
jtop = *ktop;
jbot = *kbot;
}
if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
/* ==== Updates not exploiting the 2-by-2 block */
/* . structure of U. K1 and NU keep track of */
/* . the location and size of U in the special */
/* . cases of introducing bulges and chasing */
/* . bulges off the bottom. In these special */
/* . cases and in case the number of shifts */
/* . is NS = 2, there is no 2-by-2 block */
/* . structure to exploit. ==== */
/* Computing MAX */
i__3 = 1, i__4 = *ktop - incol;
k1 = max(i__3,i__4);
/* Computing MAX */
i__3 = 0, i__4 = ndcol - *kbot;
nu = kdu - max(i__3,i__4) - k1 + 1;
/* ==== Horizontal Multiply ==== */
i__3 = jbot;
i__4 = *nh;
for (jcol = min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 :
jcol <= i__3; jcol += i__4) {
/* Computing MIN */
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = min(i__5,i__7);
zgemm_("C", "N", &nu, &jlen, &nu, &c_b2, &u[k1 + k1 *
u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1],
ldh, &c_b1, &wh[wh_offset], ldwh);
zlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[
incol + k1 + jcol * h_dim1], ldh);
}
/* ==== Vertical multiply ==== */
i__4 = max(*ktop,incol) - 1;
i__3 = *nv;
for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
jrow += i__3) {
/* Computing MIN */
i__5 = *nv, i__7 = max(*ktop,incol) - jrow;
jlen = min(i__5,i__7);
zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &h__[jrow + (
incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1],
ldu, &c_b1, &wv[wv_offset], ldwv);
zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[
jrow + (incol + k1) * h_dim1], ldh);
}
/* ==== Z multiply (also vertical) ==== */
if (*wantz) {
i__3 = *ihiz;
i__4 = *nv;
for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
jrow += i__4) {
/* Computing MIN */
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = min(i__5,i__7);
zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &z__[jrow + (
incol + k1) * z_dim1], ldz, &u[k1 + k1 *
u_dim1], ldu, &c_b1, &wv[wv_offset], ldwv);
zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[
jrow + (incol + k1) * z_dim1], ldz)
;
}
}
} else {
/* ==== Updates exploiting U's 2-by-2 block structure. */
/* . (I2, I4, J2, J4 are the last rows and columns */
/* . of the blocks.) ==== */
i2 = (kdu + 1) / 2;
i4 = kdu;
j2 = i4 - i2;
j4 = kdu;
/* ==== KZS and KNZ deal with the band of zeros */
/* . along the diagonal of one of the triangular */
/* . blocks. ==== */
kzs = j4 - j2 - (ns + 1);
knz = ns + 1;
/* ==== Horizontal multiply ==== */
i__4 = jbot;
i__3 = *nh;
for (jcol = min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 :
jcol <= i__4; jcol += i__3) {
/* Computing MIN */
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = min(i__5,i__7);
/* ==== Copy bottom of H to top+KZS of scratch ==== */
/* (The first KZS rows get multiplied by zero.) ==== */
zlacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol *
h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh);
/* ==== Multiply by U21' ==== */
zlaset_("ALL", &kzs, &jlen, &c_b1, &c_b1, &wh[wh_offset],
ldwh);
ztrmm_("L", "U", "C", "N", &knz, &jlen, &c_b2, &u[j2 + 1
+ (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1]
, ldwh);
/* ==== Multiply top of H by U11' ==== */
zgemm_("C", "N", &i2, &jlen, &j2, &c_b2, &u[u_offset],
ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b2,
&wh[wh_offset], ldwh);
/* ==== Copy top of H to bottom of WH ==== */
zlacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1]
, ldh, &wh[i2 + 1 + wh_dim1], ldwh);
/* ==== Multiply by U21' ==== */
ztrmm_("L", "L", "C", "N", &j2, &jlen, &c_b2, &u[(i2 + 1)
* u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
zgemm_("C", "N", &i__5, &jlen, &i__7, &c_b2, &u[j2 + 1 + (
i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 +
jcol * h_dim1], ldh, &c_b2, &wh[i2 + 1 + wh_dim1],
ldwh);
/* ==== Copy it back ==== */
zlacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[
incol + 1 + jcol * h_dim1], ldh);
}
/* ==== Vertical multiply ==== */
i__3 = max(incol,*ktop) - 1;
i__4 = *nv;
for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
jrow += i__4) {
/* Computing MIN */
i__5 = *nv, i__7 = max(incol,*ktop) - jrow;
jlen = min(i__5,i__7);
/* ==== Copy right of H to scratch (the first KZS */
/* . columns get multiplied by zero) ==== */
zlacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) *
h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv);
/* ==== Multiply by U21 ==== */
zlaset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[wv_offset],
ldwv);
ztrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2 + 1
+ (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) *
wv_dim1 + 1], ldwv);
/* ==== Multiply by U11 ==== */
zgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &h__[jrow + (
incol + 1) * h_dim1], ldh, &u[u_offset], ldu, &
c_b2, &wv[wv_offset], ldwv);
/* ==== Copy left of H to right of scratch ==== */
zlacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) *
h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv);
/* ==== Multiply by U21 ==== */
i__5 = i4 - i2;
ztrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(i2 +
1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1]
, ldwv);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
zgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &h__[jrow + (
incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 +
1) * u_dim1], ldu, &c_b2, &wv[(i2 + 1) * wv_dim1
+ 1], ldwv);
/* ==== Copy it back ==== */
zlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[
jrow + (incol + 1) * h_dim1], ldh);
}
/* ==== Multiply Z (also vertical) ==== */
if (*wantz) {
i__4 = *ihiz;
i__3 = *nv;
for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
jrow += i__3) {
/* Computing MIN */
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = min(i__5,i__7);
/* ==== Copy right of Z to left of scratch (first */
/* . KZS columns get multiplied by zero) ==== */
zlacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 +
j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 +
1], ldwv);
/* ==== Multiply by U12 ==== */
zlaset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[
wv_offset], ldwv);
ztrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2
+ 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1)
* wv_dim1 + 1], ldwv);
/* ==== Multiply by U11 ==== */
zgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &z__[jrow + (
incol + 1) * z_dim1], ldz, &u[u_offset], ldu,
&c_b2, &wv[wv_offset], ldwv);
/* ==== Copy left of Z to right of scratch ==== */
zlacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) *
z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1],
ldwv);
/* ==== Multiply by U21 ==== */
i__5 = i4 - i2;
ztrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(
i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) *
wv_dim1 + 1], ldwv);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
zgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &z__[
jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2
+ 1 + (i2 + 1) * u_dim1], ldu, &c_b2, &wv[(i2
+ 1) * wv_dim1 + 1], ldwv);
/* ==== Copy the result back to Z ==== */
zlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &
z__[jrow + (incol + 1) * z_dim1], ldz);
}
}
}
}
}
/* ==== End of ZLAQR5 ==== */
return 0;
} /* zlaqr5_ */
void cblas_ztrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
const enum CBLAS_DIAG Diag, const integer M, const integer N,
const void *alpha, const void *A, const integer lda,
void *B, const integer ldb)
{
char UL, TA, SD, DI;
#ifdef F77_CHAR
F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI;
#else
#define F77_TA &TA
#define F77_UL &UL
#define F77_SD &SD
#define F77_DI &DI
#endif
#define F77_M M
#define F77_N N
#define F77_lda lda
#define F77_ldb ldb
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if( Order == CblasColMajor )
{
if( Side == CblasRight ) SD='R';
else if ( Side == CblasLeft ) SD='L';
else
{
cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if( Uplo == CblasUpper ) UL='U';
else if ( Uplo == CblasLower ) UL='L';
else
{
cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if( TransA == CblasTrans ) TA ='T';
else if ( TransA == CblasConjTrans ) TA='C';
else if ( TransA == CblasNoTrans ) TA='N';
else
{
cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if( Diag == CblasUnit ) DI='U';
else if ( Diag == CblasNonUnit ) DI='N';
else
{
cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TA = C2F_CHAR(&TA);
F77_SD = C2F_CHAR(&SD);
F77_DI = C2F_CHAR(&DI);
#endif
ztrmm_(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb);
} else if (Order == CblasRowMajor)
{
RowMajorStrg = 1;
if( Side == CblasRight ) SD='L';
else if ( Side == CblasLeft ) SD='R';
else
{
cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if( Uplo == CblasUpper ) UL='L';
else if ( Uplo == CblasLower ) UL='U';
else
{
cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if( TransA == CblasTrans ) TA ='T';
else if ( TransA == CblasConjTrans ) TA='C';
else if ( TransA == CblasNoTrans ) TA='N';
else
{
cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if( Diag == CblasUnit ) DI='U';
else if ( Diag == CblasNonUnit ) DI='N';
else
{
cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TA = C2F_CHAR(&TA);
F77_SD = C2F_CHAR(&SD);
F77_DI = C2F_CHAR(&DI);
#endif
ztrmm_(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb);
}
else cblas_xerbla(1, "cblas_ztrmm", "Illegal Order setting, %d\n", Order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
int main( int argc, char** argv )
{
obj_t a, c;
obj_t c_save;
obj_t alpha;
dim_t m, n;
dim_t p;
dim_t p_begin, p_end, p_inc;
int m_input, n_input;
ind_t ind;
num_t dt;
char dt_ch;
int r, n_repeats;
side_t side;
uplo_t uploa;
trans_t transa;
diag_t diaga;
f77_char f77_side;
f77_char f77_uploa;
f77_char f77_transa;
f77_char f77_diaga;
double dtime;
double dtime_save;
double gflops;
//bli_init();
//bli_error_checking_level_set( BLIS_NO_ERROR_CHECKING );
n_repeats = 3;
dt = DT;
ind = IND;
p_begin = P_BEGIN;
p_end = P_END;
p_inc = P_INC;
m_input = -1;
n_input = -1;
// Supress compiler warnings about unused variable 'ind'.
( void )ind;
#if 0
cntx_t* cntx;
ind_t ind_mod = ind;
// A hack to use 3m1 as 1mpb (with 1m as 1mbp).
if ( ind == BLIS_3M1 ) ind_mod = BLIS_1M;
// Initialize a context for the current induced method and datatype.
cntx = bli_gks_query_ind_cntx( ind_mod, dt );
// Set k to the kc blocksize for the current datatype.
k_input = bli_cntx_get_blksz_def_dt( dt, BLIS_KC, cntx );
#elif 1
//k_input = 256;
#endif
// Choose the char corresponding to the requested datatype.
if ( bli_is_float( dt ) ) dt_ch = 's';
else if ( bli_is_double( dt ) ) dt_ch = 'd';
else if ( bli_is_scomplex( dt ) ) dt_ch = 'c';
else dt_ch = 'z';
#if 0
side = BLIS_LEFT;
#else
side = BLIS_RIGHT;
#endif
#if 0
uploa = BLIS_LOWER;
#else
uploa = BLIS_UPPER;
#endif
transa = BLIS_NO_TRANSPOSE;
diaga = BLIS_NONUNIT_DIAG;
bli_param_map_blis_to_netlib_side( side, &f77_side );
bli_param_map_blis_to_netlib_uplo( uploa, &f77_uploa );
bli_param_map_blis_to_netlib_trans( transa, &f77_transa );
bli_param_map_blis_to_netlib_diag( diaga, &f77_diaga );
// Begin with initializing the last entry to zero so that
// matlab allocates space for the entire array once up-front.
for ( p = p_begin; p + p_inc <= p_end; p += p_inc ) ;
#ifdef BLIS
printf( "data_%s_%ctrmm_%s_blis", THR_STR, dt_ch, STR );
#else
printf( "data_%s_%ctrmm_%s", THR_STR, dt_ch, STR );
#endif
printf( "( %2lu, 1:3 ) = [ %4lu %4lu %7.2f ];\n",
( unsigned long )(p - p_begin + 1)/p_inc + 1,
( unsigned long )0,
( unsigned long )0, 0.0 );
for ( p = p_begin; p <= p_end; p += p_inc )
{
if ( m_input < 0 ) m = p / ( dim_t )abs(m_input);
else m = ( dim_t ) m_input;
if ( n_input < 0 ) n = p / ( dim_t )abs(n_input);
else n = ( dim_t ) n_input;
bli_obj_create( dt, 1, 1, 0, 0, &alpha );
if ( bli_does_trans( side ) )
bli_obj_create( dt, m, m, 0, 0, &a );
else
bli_obj_create( dt, n, n, 0, 0, &a );
bli_obj_create( dt, m, n, 0, 0, &c );
bli_obj_create( dt, m, n, 0, 0, &c_save );
bli_randm( &a );
bli_randm( &c );
bli_obj_set_struc( BLIS_TRIANGULAR, &a );
bli_obj_set_uplo( uploa, &a );
bli_obj_set_conjtrans( transa, &a );
bli_obj_set_diag( diaga, &a );
bli_randm( &a );
bli_mktrim( &a );
bli_setsc( (2.0/1.0), 0.0, &alpha );
bli_copym( &c, &c_save );
#if 0 //def BLIS
bli_ind_disable_all_dt( dt );
bli_ind_enable_dt( ind, dt );
#endif
dtime_save = DBL_MAX;
for ( r = 0; r < n_repeats; ++r )
{
bli_copym( &c_save, &c );
dtime = bli_clock();
#ifdef PRINT
bli_printm( "a", &a, "%4.1f", "" );
bli_printm( "c", &c, "%4.1f", "" );
#endif
#ifdef BLIS
bli_trmm( side,
&alpha,
&a,
&c );
#else
if ( bli_is_float( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
float* alphap = bli_obj_buffer( &alpha );
float* ap = bli_obj_buffer( &a );
float* cp = bli_obj_buffer( &c );
strmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
else if ( bli_is_double( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
double* alphap = bli_obj_buffer( &alpha );
double* ap = bli_obj_buffer( &a );
double* cp = bli_obj_buffer( &c );
dtrmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
else if ( bli_is_scomplex( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
scomplex* alphap = bli_obj_buffer( &alpha );
scomplex* ap = bli_obj_buffer( &a );
scomplex* cp = bli_obj_buffer( &c );
ctrmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
else if ( bli_is_dcomplex( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
dcomplex* alphap = bli_obj_buffer( &alpha );
dcomplex* ap = bli_obj_buffer( &a );
dcomplex* cp = bli_obj_buffer( &c );
ztrmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#ifdef PRINT
bli_printm( "c after", &c, "%4.1f", "" );
exit(1);
#endif
dtime_save = bli_clock_min_diff( dtime_save, dtime );
}
if ( bli_is_left( side ) )
gflops = ( 1.0 * m * m * n ) / ( dtime_save * 1.0e9 );
else
gflops = ( 1.0 * m * n * n ) / ( dtime_save * 1.0e9 );
if ( bli_is_complex( dt ) ) gflops *= 4.0;
#ifdef BLIS
printf( "data_%s_%ctrmm_%s_blis", THR_STR, dt_ch, STR );
#else
printf( "data_%s_%ctrmm_%s", THR_STR, dt_ch, STR );
#endif
printf( "( %2lu, 1:3 ) = [ %4lu %4lu %7.2f ];\n",
( unsigned long )(p - p_begin + 1)/p_inc + 1,
( unsigned long )m,
( unsigned long )n, gflops );
bli_obj_free( &alpha );
bli_obj_free( &a );
bli_obj_free( &c );
bli_obj_free( &c_save );
}
//bli_finalize();
return 0;
}
void
ztrmm(char side, char uplo, char transa, char diag, int m, int n, doublecomplex *alpha, doublecomplex *a, int lda, doublecomplex *b, int ldb)
{
ztrmm_(&side, &uplo, &transa, &diag, &m, &n, alpha, a, &lda, b, &ldb);
}
/* Subroutine */ int zhegv_(integer *itype, char *jobz, char *uplo, integer *
n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, neig;
char trans[1];
logical upper, wantz;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZHEGV computes all the eigenvalues, and optionally, the eigenvectors */
/* of a complex generalized Hermitian-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
/* Here A and B are assumed to be Hermitian and B is also */
/* positive definite. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* 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. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
/* matrix Z of eigenvectors. The eigenvectors are normalized */
/* as follows: */
/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
/* or the lower triangle (if UPLO='L') of A, including the */
/* diagonal, is destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
/* On entry, the Hermitian positive definite matrix B. */
/* If UPLO = 'U', the leading N-by-N upper triangular part of B */
/* contains the upper triangular part of the matrix B. */
/* If UPLO = 'L', the leading N-by-N lower triangular part of B */
/* contains the lower triangular part of the matrix B. */
/* On exit, if INFO <= N, the part of B containing the matrix is */
/* overwritten by the triangular factor U or L from the Cholesky */
/* factorization B = U**H*U or B = L*L**H. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,2*N-1). */
/* For optimal efficiency, LWORK >= (NB+1)*N, */
/* where NB is the blocksize for ZHETRD returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: ZPOTRF or ZHEEV returned an error code: */
/* <= N: if INFO = i, ZHEEV failed to converge; */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero; */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info == 0) {
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 1) * *n;
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
zpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
, info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ztrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ztrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZHEGV */
} /* zhegv_ */
/* 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_ */
int zgehrd_(int *n, int *ilo, int *ihi,
doublecomplex *a, int *lda, doublecomplex *tau, doublecomplex *
work, int *lwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
int i__, j;
doublecomplex t[4160] /* was [65][64] */;
int ib;
doublecomplex ei;
int nb, nh, nx, iws, nbmin, iinfo;
extern int zgemm_(char *, char *, int *, int *,
int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, doublecomplex *,
int *), ztrmm_(char *, char *, char *, char *,
int *, int *, doublecomplex *, doublecomplex *, int *
, doublecomplex *, int *),
zaxpy_(int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *), zgehd2_(int *, int *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *), zlahr2_(int *, int *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *), xerbla_(
char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int zlarfb_(char *, char *, char *, char *,
int *, int *, int *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *, int *);
int ldwork, lwkopt;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by */
/* an unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, 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). */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
/* zero. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= MAX(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-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(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( 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 ZGEHRD */
/* subroutine incorporating improvements proposed by Quintana-Orti and */
/* Van de Geijn (2005). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
nb = MIN(i__1,i__2);
lwkopt = *n * nb;
work[1].r = (double) lwkopt, work[1].i = 0.;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > MAX(1,*n)) {
*info = -2;
} else if (*ihi < MIN(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEHRD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L10: */
}
i__1 = *n - 1;
for (i__ = MAX(1,*ihi); i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L20: */
}
/* Quick return if possible */
nh = *ihi - *ilo + 1;
if (nh <= 1) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size */
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
nb = MIN(i__1,i__2);
nbmin = 2;
iws = 1;
if (nb > 1 && nb < nh) {
/* Determine when to cross over from blocked to unblocked code */
/* (last block is always handled by unblocked code) */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
nx = MAX(i__1,i__2);
if (nx < nh) {
/* Determine if workspace is large enough for blocked code */
iws = *n * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: determine the */
/* minimum value of NB, and reduce NB or force use of */
/* unblocked code */
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEHRD", " ", n, ilo, ihi, &
c_n1);
nbmin = MAX(i__1,i__2);
if (*lwork >= *n * nbmin) {
nb = *lwork / *n;
} else {
nb = 1;
}
}
}
}
ldwork = *n;
if (nb < nbmin || nb >= nh) {
/* Use unblocked code below */
i__ = *ilo;
} else {
/* Use blocked code */
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *ihi - i__;
ib = MIN(i__3,i__4);
/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
/* matrices V and T of the block reflector H = I - V*T*V' */
/* which performs the reduction, and also the matrix Y = A*V*T */
zlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
c__65, &work[1], &ldwork);
/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */
/* to 1 */
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
ei.r = a[i__3].r, ei.i = a[i__3].i;
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = 1., a[i__3].i = 0.;
i__3 = *ihi - i__ - ib + 1;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, &
z__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda,
&c_b2, &a[(i__ + ib) * a_dim1 + 1], lda);
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = ei.r, a[i__3].i = ei.i;
/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
/* right */
i__3 = ib - 1;
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &i__, &
i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &
ldwork);
i__3 = ib - 2;
for (j = 0; j <= i__3; ++j) {
z__1.r = -1., z__1.i = -0.;
zaxpy_(&i__, &z__1, &work[ldwork * j + 1], &c__1, &a[(i__ + j
+ 1) * a_dim1 + 1], &c__1);
/* L30: */
}
/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
/* left */
i__3 = *ihi - i__;
i__4 = *n - i__ - ib + 1;
zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", &
i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &
c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &
ldwork);
/* L40: */
}
}
/* Use unblocked code to reduce the rest of the matrix */
zgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
work[1].r = (double) iws, work[1].i = 0.;
return 0;
/* End of ZGEHRD */
} /* zgehrd_ */
