static void zget_wv(double complex *w, double complex *v,
double complex *cache, double complex *fvohalf,
double complex *vooo, double complex *vv_op,
double complex *t1Thalf, double complex *t2T,
int nocc, int nvir, int a, int b, int c, int *idx)
{
const double complex D0 = 0;
const double complex D1 = 1;
const double complex DN1 =-1;
const char TRANS_N = 'N';
const int nmo = nocc + nvir;
const int noo = nocc * nocc;
const size_t nooo = nocc * noo;
const size_t nvoo = nvir * noo;
int i, j, k, n;
double complex *pt2T;
zgemm_(&TRANS_N, &TRANS_N, &noo, &nocc, &nvir,
&D1, t2T+c*nvoo, &noo, vv_op+nocc, &nmo,
&D0, cache, &noo);
zgemm_(&TRANS_N, &TRANS_N, &nocc, &noo, &nocc,
&DN1, t2T+c*nvoo+b*noo, &nocc, vooo+a*nooo, &nocc,
&D1, cache, &nocc);
pt2T = t2T + b * nvoo + a * noo;
for (n = 0, i = 0; i < nocc; i++) {
for (j = 0; j < nocc; j++) {
for (k = 0; k < nocc; k++, n++) {
w[idx[n]] += cache[n];
v[idx[n]] +=(vv_op[i*nmo+j] * t1Thalf[c*nocc+k]
+ pt2T[i*nocc+j] * fvohalf[c*nocc+k]);
} } }
}
/*! zgematrix*=_zgematrix operator */
inline zgematrix& zgematrix::operator*=(const _zgematrix& mat)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] zgematrix::operator*=(const _zgematrix&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(N!=mat.M){
std::cerr << "[ERROR] zgematrix::operator*=(_zgematrix&)" << std::endl
<< "These two matrises can not make a product." << std::endl
<< "Your input was (" << M << "x" << N << ") *= ("
<< mat.M << "x" << mat.N << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
zgematrix newmat( M, mat.N );
zgemm_( 'N', 'N', M, mat.N, N, std::complex<double>(1.0,0.0), Array, M,
mat.Array, mat.M, std::complex<double>(0.0,0.0), newmat.array, M );
swap(*this,newmat);
mat.destroy();
return *this;
}
/*! zgematrix*_zgematrix operator */
inline _zgematrix operator*(const zgematrix& matA, const _zgematrix& matB)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] operator*(const zgematrix&, const _zgematrix&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(matA.N!=matB.M){
std::cerr << "[ERROR] operator*(zgematrix&, _zgematrix&)" << std::endl
<< "These two matrises can not make a product." << std::endl
<< "Your input was (" << matA.M << "x" << matA.N << ") * ("
<< matB.M << "x" << matB.N << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
zgematrix newmat( matA.M, matB.N );
zgemm_( 'N', 'N', matA.M, matB.N, matA.N, std::complex<double>(1.0,0.0),
matA.Array, matA.M, matB.Array, matB.M,
std::complex<double>(0.0,0.0), newmat.array, matA.M );
matB.destroy();
return _(newmat);
}
int
f2c_zgemm(char* transA, char* transB, integer* M, integer* N, integer* K,
doublecomplex* alpha,
doublecomplex* A, integer* lda,
doublecomplex* B, integer* ldb,
doublecomplex* beta,
doublecomplex* C, integer* ldc)
{
zgemm_(transA, transB, M, N, K,
alpha, A, lda, B, ldb, beta, C, ldc);
return 0;
}
static void dot_ao_dm(double complex *vm, double complex *ao, double complex *dm,
int nao, int nocc, int ngrids, int bgrids,
unsigned char *non0table, int *shls_slice, int *ao_loc)
{
int nbox = (nao+BOXSIZE-1) / BOXSIZE;
char empty[nbox];
int has0 = VXCao_empty_blocks(empty, non0table, shls_slice, ao_loc);
const char TRANS_T = 'T';
const char TRANS_N = 'N';
const double complex Z1 = 1;
double complex beta = 0;
if (has0) {
int box_id, blen, i, j;
size_t b0;
for (box_id = 0; box_id < nbox; box_id++) {
if (!empty[box_id]) {
b0 = box_id * BOXSIZE;
blen = MIN(nao-b0, BOXSIZE);
zgemm_(&TRANS_N, &TRANS_T, &bgrids, &nocc, &blen,
&Z1, ao+b0*ngrids, &ngrids, dm+b0*nocc, &nocc,
&beta, vm, &ngrids);
beta = 1.0;
}
}
if (beta == 0) { // all empty
for (i = 0; i < nocc; i++) {
for (j = 0; j < bgrids; j++) {
vm[i*ngrids+j] = 0;
}
}
}
} else {
zgemm_(&TRANS_N, &TRANS_T, &bgrids, &nocc, &nao,
&Z1, ao, &ngrids, dm, &nocc, &beta, vm, &ngrids);
}
}
/* conj(vv[n,m]) = ao1[n,ngrids] * conj(ao2[m,ngrids]) */
static void dot_ao_ao(double complex *vv, double complex *ao1, double complex *ao2,
int nao, int ngrids, int bgrids, int hermi,
unsigned char *non0table, int *shls_slice, int *ao_loc)
{
int nbox = (nao+BOXSIZE-1) / BOXSIZE;
char empty[nbox];
int has0 = VXCao_empty_blocks(empty, non0table, shls_slice, ao_loc);
const char TRANS_C = 'C';
const char TRANS_N = 'N';
const double complex Z1 = 1;
if (has0) {
int ib, jb, leni, lenj;
int j1 = nbox;
size_t b0i, b0j;
for (ib = 0; ib < nbox; ib++) {
if (!empty[ib]) {
b0i = ib * BOXSIZE;
leni = MIN(nao-b0i, BOXSIZE);
if (hermi) {
j1 = ib + 1;
}
for (jb = 0; jb < j1; jb++) {
if (!empty[jb]) {
b0j = jb * BOXSIZE;
lenj = MIN(nao-b0j, BOXSIZE);
zgemm_(&TRANS_C, &TRANS_N, &lenj, &leni, &bgrids, &Z1,
ao2+b0j*ngrids, &ngrids, ao1+b0i*ngrids, &ngrids,
&Z1, vv+b0i*nao+b0j, &nao);
} }
} }
} else {
zgemm_(&TRANS_C, &TRANS_N, &nao, &nao, &bgrids,
&Z1, ao2, &ngrids, ao1, &ngrids, &Z1, vv, &nao);
}
}
PyObject* gemm(PyObject *self, PyObject *args)
{
Py_complex alpha;
PyArrayObject* a;
PyArrayObject* b;
Py_complex beta;
PyArrayObject* c;
char transa = 'n';
if (!PyArg_ParseTuple(args, "DOODO|c", &alpha, &a, &b, &beta, &c, &transa))
return NULL;
int m, k, lda, ldb, ldc;
if (transa == 'n')
{
m = PyArray_DIMS(a)[1];
for (int i = 2; i < PyArray_NDIM(a); i++)
m *= PyArray_DIMS(a)[i];
k = PyArray_DIMS(a)[0];
lda = MAX(1, PyArray_STRIDES(a)[0] / PyArray_STRIDES(a)[PyArray_NDIM(a) - 1]);
ldb = MAX(1, PyArray_STRIDES(b)[0] / PyArray_STRIDES(b)[1]);
ldc = MAX(1, PyArray_STRIDES(c)[0] / PyArray_STRIDES(c)[PyArray_NDIM(c) - 1]);
}
else
{
k = PyArray_DIMS(a)[1];
for (int i = 2; i < PyArray_NDIM(a); i++)
k *= PyArray_DIMS(a)[i];
m = PyArray_DIMS(a)[0];
lda = MAX(1, k);
ldb = MAX(1, PyArray_STRIDES(b)[0] / PyArray_STRIDES(b)[PyArray_NDIM(b) - 1]);
ldc = MAX(1, PyArray_STRIDES(c)[0] / PyArray_STRIDES(c)[1]);
}
int n = PyArray_DIMS(b)[0];
if (PyArray_DESCR(a)->type_num == NPY_DOUBLE)
dgemm_(&transa, "n", &m, &n, &k,
&(alpha.real),
DOUBLEP(a), &lda,
DOUBLEP(b), &ldb,
&(beta.real),
DOUBLEP(c), &ldc);
else
zgemm_(&transa, "n", &m, &n, &k,
&alpha,
(void*)COMPLEXP(a), &lda,
(void*)COMPLEXP(b), &ldb,
&beta,
(void*)COMPLEXP(c), &ldc);
Py_RETURN_NONE;
}
/*! zgematrix*_zgematrix operator */
inline _zgematrix operator*(const zgematrix& matA, const _zgematrix& matB)
{VERBOSE_REPORT;
#ifdef CPPL_DEBUG
if(matA.n!=matB.m){
ERROR_REPORT;
std::cerr << "These two matrises can not make a product." << std::endl
<< "Your input was (" << matA.m << "x" << matA.n << ") * (" << matB.m << "x" << matB.n << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
zgematrix newmat( matA.m, matB.n );
zgemm_( 'n', 'n', matA.m, matB.n, matA.n, comple(1.0,0.0),
matA.array, matA.m, matB.array, matB.m,
comple(0.0,0.0), newmat.array, matA.m );
matB.destroy();
return _(newmat);
}
/*! zgematrix*=_zgematrix operator */
inline zgematrix& zgematrix::operator*=(const _zgematrix& mat)
{VERBOSE_REPORT;
#ifdef CPPL_DEBUG
if(n!=mat.m){
ERROR_REPORT;
std::cerr << "These two matrises can not make a product." << std::endl
<< "Your input was (" << m << "x" << n << ") *= (" << mat.m << "x" << mat.n << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
zgematrix newmat( m, mat.n );
zgemm_( 'n', 'n', m, mat.n, n, comple(1.0,0.0), array, m,
mat.array, mat.m, comple(0.0,0.0), newmat.array, m );
swap(*this,newmat);
mat.destroy();
return *this;
}
/*
* transform bra (without doing conj(mo)), v_{iq} = C_{pi} v_{pq}
* s1 to label AO symmetry
*/
int RIhalfmmm_r_s1_bra_noconj(double complex *vout, double complex *vin,
struct _AO2MOEnvs *envs, int seekdim)
{
switch (seekdim) {
case 1: return envs->bra_count * envs->nao;
case 2: return envs->nao * envs->nao;
}
const double complex Z0 = 0;
const double complex Z1 = 1;
const char TRANS_N = 'N';
int n2c = envs->nao;
int i_start = envs->bra_start;
int i_count = envs->bra_count;
double complex *mo_coeff = envs->mo_coeff;
zgemm_(&TRANS_N, &TRANS_N, &n2c, &i_count, &n2c,
&Z1, vin, &n2c, mo_coeff+i_start*n2c, &n2c,
&Z0, vout, &n2c);
return 0;
}
void
cublasDgemm( char transA, char transB, int m, int n, int k,
double alpha, double *A, int ldA,
double *B, int ldB,
double beta, double *C, int ldC )
{
double zalpha_[REAL_PART+IMAG_PART+1];
double zbeta_[REAL_PART+IMAG_PART+1];
double *zalpha = &(zalpha_[0]);
double *zbeta = &(zbeta_[0]);
zalpha[REAL_PART] = creal(alpha);
zalpha[IMAG_PART] = cimag(alpha);
zbeta[REAL_PART] = creal(beta);
zbeta[IMAG_PART] = cimag(beta);
zgemm_( &transA, &transB, &m, &n, &k,
zalpha, (double *) A, &ldA, (double *) B, &ldB,
zbeta, (double *) C, &ldC );
}
/*
* transform ket, s1 to label AO symmetry
*/
int RIhalfmmm_r_s1_ket(double complex *vout, double complex *vin,
struct _AO2MOEnvs *envs, int seekdim)
{
switch (seekdim) {
case 1: return envs->nao * envs->ket_count;
case 2: return envs->nao * envs->nao;
}
const double complex Z0 = 0;
const double complex Z1 = 1;
const char TRANS_T = 'T';
const char TRANS_N = 'N';
int n2c = envs->nao;
int j_start = envs->ket_start;
int j_count = envs->ket_count;
double complex *mo_coeff = envs->mo_coeff;
zgemm_(&TRANS_T, &TRANS_N, &j_count, &n2c, &n2c,
&Z1, mo_coeff+j_start*n2c, &n2c, vin, &n2c,
&Z0, vout, &j_count);
return 0;
}
// Interface to lapack routine zgemm
// mm: nrow of A
// nn: ncol of B
// kk: ncol and nrow of C
void lapack_zgemm(int mm, int nn, int kk,
char transa, char transb,
dcmplx alpha, dcmplx *AA, dcmplx *BB,
dcmplx beta, dcmplx *CC)
{
int lda, ldb, ldc;
if(transa == 'N' || transa == 'n') {
lda = (1 > mm) ? 1 : mm;
} else {
lda = (1 > kk) ? 1 : kk;
}
if(transb == 'N' || transb == 'n') {
ldb = (1 > kk) ? 1 : kk;
} else {
ldb = (1 > nn) ? 1 : nn;
}
ldc = (1 > mm) ? 1 : mm;
zgemm_(&transa, &transb, &mm, &nn, &kk, &alpha, AA, &lda, BB, &ldb, &beta, CC, &ldc);
}
/* 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 zgebrd_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq,
doublecomplex *taup, doublecomplex *work, integer *lwork, integer *
info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZGEBRD reduces a general complex M-by-N matrix A to upper or lower
bidiagonal form B by a unitary transformation: Q**H * A * P = B.
If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
Arguments
=========
M (input) INTEGER
The number of rows in the matrix A. M >= 0.
N (input) INTEGER
The number of columns in the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N general matrix to be reduced.
On exit,
if m >= n, the diagonal and the first superdiagonal are
overwritten with the upper bidiagonal matrix B; the
elements below the diagonal, with the array TAUQ, represent
the unitary matrix Q as a product of elementary
reflectors, and the elements above the first superdiagonal,
with the array TAUP, represent the unitary matrix P as
a product of elementary reflectors;
if m < n, the diagonal and the first subdiagonal are
overwritten with the lower bidiagonal matrix B; the
elements below the first subdiagonal, with the array TAUQ,
represent the unitary matrix Q as a product of
elementary reflectors, and the elements above the diagonal,
with the array TAUP, represent the unitary matrix P as
a product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
D (output) DOUBLE PRECISION array, dimension (min(M,N))
The diagonal elements of the bidiagonal matrix B:
D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
The off-diagonal elements of the bidiagonal matrix B:
if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
TAUQ (output) COMPLEX*16 array dimension (min(M,N))
The scalar factors of the elementary reflectors which
represent the unitary matrix Q. See Further Details.
TAUP (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors which
represent the unitary matrix P. See Further Details.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,M,N).
For optimum performance LWORK >= (M+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 matrices Q and P are represented as products of elementary
reflectors:
If m >= n,
Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
Each H(i) and G(i) has the form:
H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
where tauq and taup are complex scalars, and v and u are complex
vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
If m < n,
Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
Each H(i) and G(i) has the form:
H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
where tauq and taup are complex scalars, and v and u are complex
vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
The contents of A on exit are illustrated by the following examples:
m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
( v1 v2 v3 v4 v5 )
where d and e denote diagonal and off-diagonal elements of B, vi
denotes an element of the vector defining H(i), and ui an element of
the vector defining G(i).
=====================================================================
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;
static integer c__3 = 3;
static integer c__2 = 2;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
static integer i__, j, nbmin, iinfo, minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgebd2_(integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer nb, nx;
static doublereal ws;
extern /* Subroutine */ int xerbla_(char *, integer *), zlabrd_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ldwrkx, ldwrky, lwkopt;
static logical lquery;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
--work;
/* Function Body */
*info = 0;
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
lwkopt = (*m + *n) * nb;
d__1 = (doublereal) lwkopt;
work[1].r = d__1, work[1].i = 0.;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*lwork < max(i__1,*n) && ! lquery) {
*info = -10;
}
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZGEBRD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
minmn = min(*m,*n);
if (minmn == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
ws = (doublereal) max(*m,*n);
ldwrkx = *m;
ldwrky = *n;
if (nb > 1 && nb < minmn) {
/* Set the crossover point NX.
Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEBRD", " ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
/* Determine when to switch from blocked to unblocked code. */
if (nx < minmn) {
ws = (doublereal) ((*m + *n) * nb);
if ((doublereal) (*lwork) < ws) {
/* Not enough work space for the optimal NB, consider using
a smaller block size. */
nbmin = ilaenv_(&c__2, "ZGEBRD", " ", m, n, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
if (*lwork >= (*m + *n) * nbmin) {
nb = *lwork / (*m + *n);
} else {
nb = 1;
nx = minmn;
}
}
}
} else {
nx = minmn;
}
i__1 = minmn - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Reduce rows and columns i:i+ib-1 to bidiagonal form and return
the matrices X and Y which are needed to update the unreduced
part of the matrix */
i__3 = *m - i__ + 1;
i__4 = *n - i__ + 1;
zlabrd_(&i__3, &i__4, &nb, &a_ref(i__, i__), lda, &d__[i__], &e[i__],
&tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx * nb
+ 1], &ldwrky);
/* Update the trailing submatrix A(i+ib:m,i+ib:n), using
an update of the form A := A - V*Y' - X*U' */
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", &i__3, &i__4, &nb, &
z__1, &a_ref(i__ + nb, i__), lda, &work[ldwrkx * nb + nb + 1],
&ldwrky, &c_b1, &a_ref(i__ + nb, i__ + nb), lda);
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &z__1, &
work[nb + 1], &ldwrkx, &a_ref(i__, i__ + nb), lda, &c_b1, &
a_ref(i__ + nb, i__ + nb), lda);
/* Copy diagonal and off-diagonal elements of B back into A */
if (*m >= *n) {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
i__4 = a_subscr(j, j);
i__5 = j;
a[i__4].r = d__[i__5], a[i__4].i = 0.;
i__4 = a_subscr(j, j + 1);
i__5 = j;
a[i__4].r = e[i__5], a[i__4].i = 0.;
/* L10: */
}
} else {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
i__4 = a_subscr(j, j);
i__5 = j;
a[i__4].r = d__[i__5], a[i__4].i = 0.;
i__4 = a_subscr(j + 1, j);
i__5 = j;
a[i__4].r = e[i__5], a[i__4].i = 0.;
/* L20: */
}
}
/* L30: */
}
/* Use unblocked code to reduce the remainder of the matrix */
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
zgebd2_(&i__2, &i__1, &a_ref(i__, i__), lda, &d__[i__], &e[i__], &tauq[
i__], &taup[i__], &work[1], &iinfo);
work[1].r = ws, work[1].i = 0.;
return 0;
/* End of ZGEBRD */
} /* zgebrd_ */
/* Subroutine */ int zget22_(char *transa, char *transe, char *transw,
integer *n, doublecomplex *a, integer *lda, doublecomplex *e, integer
*lde, doublecomplex *w, doublecomplex *work, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer j;
doublereal ulp;
integer joff, jcol, jvec;
doublereal unfl;
integer jrow;
doublereal temp1;
extern logical lsame_(char *, char *);
char norma[1];
doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
char norme[1];
doublereal enorm;
doublecomplex wtemp;
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
doublereal enrmin, enrmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
integer itrnse;
doublereal errnrm;
integer itrnsw;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGET22 does an eigenvector check. */
/* The basic test is: */
/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
/* using the 1-norm. It also tests the normalization of E: */
/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/* j */
/* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
/* vector. The max-norm of a complex n-vector x in this case is the */
/* maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n. */
/* Arguments */
/* ========== */
/* TRANSA (input) CHARACTER*1 */
/* Specifies whether or not A is transposed. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* TRANSE (input) CHARACTER*1 */
/* Specifies whether or not E is transposed. */
/* = 'N': No transpose, eigenvectors are in columns of E */
/* = 'T': Transpose, eigenvectors are in rows of E */
/* = 'C': Conjugate transpose, eigenvectors are in rows of E */
/* TRANSW (input) CHARACTER*1 */
/* Specifies whether or not W is transposed. */
/* = 'N': No transpose */
/* = 'T': Transpose, same as TRANSW = 'N' */
/* = 'C': Conjugate transpose, use -WI(j) instead of WI(j) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The matrix whose eigenvectors are in E. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* E (input) COMPLEX*16 array, dimension (LDE,N) */
/* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
/* are stored in the columns of E, if TRANSE = 'T' or 'C', the */
/* eigenvectors are stored in the rows of E. */
/* LDE (input) INTEGER */
/* The leading dimension of the array E. LDE >= max(1,N). */
/* W (input) COMPLEX*16 array, dimension (N) */
/* The eigenvalues of A. */
/* WORK (workspace) COMPLEX*16 array, dimension (N*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/* j */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize RESULT (in case N=0) */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1;
e -= e_offset;
--w;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
result[2] = 0.;
if (*n <= 0) {
return 0;
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Precision");
itrnse = 0;
itrnsw = 0;
*(unsigned char *)norma = 'O';
*(unsigned char *)norme = 'O';
if (lsame_(transa, "T") || lsame_(transa, "C")) {
*(unsigned char *)norma = 'I';
}
if (lsame_(transe, "T")) {
itrnse = 1;
*(unsigned char *)norme = 'I';
} else if (lsame_(transe, "C")) {
itrnse = 2;
*(unsigned char *)norme = 'I';
}
if (lsame_(transw, "C")) {
itrnsw = 1;
}
/* Normalization of E: */
enrmin = 1. / ulp;
enrmax = 0.;
if (itrnse == 0) {
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
temp1 = 0.;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = j + jvec * e_dim1;
d__3 = temp1, d__4 = (d__1 = e[i__3].r, abs(d__1)) + (d__2 =
d_imag(&e[j + jvec * e_dim1]), abs(d__2));
temp1 = max(d__3,d__4);
/* L10: */
}
enrmin = min(enrmin,temp1);
enrmax = max(enrmax,temp1);
/* L20: */
}
} else {
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
rwork[jvec] = 0.;
/* L30: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (jvec = 1; jvec <= i__2; ++jvec) {
/* Computing MAX */
i__3 = jvec + j * e_dim1;
d__3 = rwork[jvec], d__4 = (d__1 = e[i__3].r, abs(d__1)) + (
d__2 = d_imag(&e[jvec + j * e_dim1]), abs(d__2));
rwork[jvec] = max(d__3,d__4);
/* L40: */
}
/* L50: */
}
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
/* Computing MIN */
d__1 = enrmin, d__2 = rwork[jvec];
enrmin = min(d__1,d__2);
/* Computing MAX */
d__1 = enrmax, d__2 = rwork[jvec];
enrmax = max(d__1,d__2);
/* L60: */
}
}
/* Norm of A: */
/* Computing MAX */
d__1 = zlange_(norma, n, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Norm of E: */
/* Computing MAX */
d__1 = zlange_(norme, n, n, &e[e_offset], lde, &rwork[1]);
enorm = max(d__1,ulp);
/* Norm of error: */
/* Error = AE - EW */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
joff = 0;
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (itrnsw == 0) {
i__2 = jcol;
wtemp.r = w[i__2].r, wtemp.i = w[i__2].i;
} else {
d_cnjg(&z__1, &w[jcol]);
wtemp.r = z__1.r, wtemp.i = z__1.i;
}
if (itrnse == 0) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
i__4 = jrow + jcol * e_dim1;
z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L70: */
}
} else if (itrnse == 1) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
i__4 = jcol + jrow * e_dim1;
z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
}
} else {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
d_cnjg(&z__2, &e[jcol + jrow * e_dim1]);
z__1.r = z__2.r * wtemp.r - z__2.i * wtemp.i, z__1.i = z__2.r
* wtemp.i + z__2.i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
}
joff += *n;
/* L100: */
}
z__1.r = -1., z__1.i = -0.;
zgemm_(transa, transe, n, n, n, &c_b2, &a[a_offset], lda, &e[e_offset],
lde, &z__1, &work[1], n);
errnrm = zlange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
/* Compute RESULT(1) (avoiding under/overflow) */
if (anorm > errnrm) {
result[1] = errnrm / anorm / ulp;
} else {
if (anorm < 1.) {
result[1] = min(errnrm,anorm) / anorm / ulp;
} else {
/* Computing MIN */
d__1 = errnrm / anorm;
result[1] = min(d__1,1.) / ulp;
}
}
/* Compute RESULT(2) : the normalization error in E. */
/* Computing MAX */
d__3 = (d__1 = enrmax - 1., abs(d__1)), d__4 = (d__2 = enrmin - 1., abs(
d__2));
result[2] = max(d__3,d__4) / ((doublereal) (*n) * ulp);
return 0;
/* End of ZGET22 */
} /* zget22_ */
void
zgemm(char transa, char transb, int m, int n, int k, doublecomplex *alpha, doublecomplex *a, int lda, doublecomplex *b, int ldb, doublecomplex *beta, doublecomplex *c, int ldc)
{
zgemm_(&transa, &transb, &m, &n, &k, alpha, a, &lda, b, &ldb, beta, c, &ldc);
}
/* Subroutine */ int zhfrk_(char *transr, char *uplo, char *trans, integer *n,
integer *k, doublereal *alpha, doublecomplex *a, integer *lda,
doublereal *beta, doublecomplex *c__)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
/* Local variables */
integer j, n1, n2, nk, info;
doublecomplex cbeta;
logical normaltransr;
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 *);
integer nrowa;
logical lower;
doublecomplex calpha;
extern /* Subroutine */ int xerbla_(char *, integer *);
logical nisodd, notrans;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Level 3 BLAS like routine for C in RFP Format. */
/* ZHFRK performs one of the Hermitian rank--k operations */
/* C := alpha*A*conjg( A' ) + beta*C, */
/* or */
/* C := alpha*conjg( A' )*A + beta*C, */
/* where alpha and beta are real scalars, C is an n--by--n Hermitian */
/* matrix and A is an n--by--k matrix in the first case and a k--by--n */
/* matrix in the second case. */
/* Arguments */
/* ========== */
/* TRANSR (input) CHARACTER. */
/* = 'N': The Normal Form of RFP A is stored; */
/* = 'C': The Conjugate-transpose Form of RFP A is stored. */
/* UPLO - (input) CHARACTER. */
/* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the array C is to be referenced as */
/* follows: */
/* UPLO = 'U' or 'u' Only the upper triangular part of C */
/* is to be referenced. */
/* UPLO = 'L' or 'l' Only the lower triangular part of C */
/* is to be referenced. */
/* Unchanged on exit. */
/* TRANS - (input) CHARACTER. */
/* On entry, TRANS specifies the operation to be performed as */
/* follows: */
/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */
/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */
/* Unchanged on exit. */
/* N - (input) INTEGER. */
/* On entry, N specifies the order of the matrix C. N must be */
/* at least zero. */
/* Unchanged on exit. */
/* K - (input) INTEGER. */
/* On entry with TRANS = 'N' or 'n', K specifies the number */
/* of columns of the matrix A, and on entry with */
/* TRANS = 'C' or 'c', K specifies the number of rows of the */
/* matrix A. K must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - (input) DOUBLE PRECISION. */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - (input) COMPLEX*16 array of DIMENSION ( LDA, ka ), where KA */
/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */
/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */
/* the array A must contain the matrix A, otherwise the leading */
/* K--by--N part of the array A must contain the matrix A. */
/* Unchanged on exit. */
/* LDA - (input) INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. When TRANS = 'N' or 'n' */
/* then LDA must be at least max( 1, n ), otherwise LDA must */
/* be at least max( 1, k ). */
/* Unchanged on exit. */
/* BETA - (input) DOUBLE PRECISION. */
/* On entry, BETA specifies the scalar beta. */
/* Unchanged on exit. */
/* C - (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ). */
/* On entry, the matrix A in RFP Format. RFP Format is */
/* described by TRANSR, UPLO and N. Note that the imaginary */
/* parts of the diagonal elements need not be set, they are */
/* assumed to be zero, and on exit they are set to zero. */
/* 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;
--c__;
/* Function Body */
info = 0;
normaltransr = lsame_(transr, "N");
lower = lsame_(uplo, "L");
notrans = lsame_(trans, "N");
if (notrans) {
nrowa = *n;
} else {
nrowa = *k;
}
if (! normaltransr && ! lsame_(transr, "C")) {
info = -1;
} else if (! lower && ! lsame_(uplo, "U")) {
info = -2;
} else if (! notrans && ! lsame_(trans, "C")) {
info = -3;
} else if (*n < 0) {
info = -4;
} else if (*k < 0) {
info = -5;
} else if (*lda < max(1,nrowa)) {
info = -8;
}
if (info != 0) {
i__1 = -info;
xerbla_("ZHFRK ", &i__1);
return 0;
}
/* Quick return if possible. */
/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */
/* done (it is in ZHERK for example) and left in the general case. */
if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
return 0;
}
if (*alpha == 0. && *beta == 0.) {
i__1 = *n * (*n + 1) / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
c__[i__2].r = 0., c__[i__2].i = 0.;
}
return 0;
}
z__1.r = *alpha, z__1.i = 0.;
calpha.r = z__1.r, calpha.i = z__1.i;
z__1.r = *beta, z__1.i = 0.;
cbeta.r = z__1.r, cbeta.i = z__1.i;
/* C is N-by-N. */
/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
/* If N is even, NISODD = .FALSE., and NK. */
if (*n % 2 == 0) {
nisodd = FALSE_;
nk = *n / 2;
} else {
nisodd = TRUE_;
if (lower) {
n2 = *n / 2;
n1 = *n - n2;
} else {
n1 = *n / 2;
n2 = *n - n1;
}
}
if (nisodd) {
/* N is odd */
if (normaltransr) {
/* N is odd and TRANSR = 'N' */
if (lower) {
/* N is odd, TRANSR = 'N', and UPLO = 'L' */
if (notrans) {
/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], n);
zherk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
beta, &c__[*n + 1], n);
zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[n1 + 1],
n);
} else {
/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], n);
zherk_("U", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
lda, beta, &c__[*n + 1], n)
;
zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[n1 + 1], n);
}
} else {
/* N is odd, TRANSR = 'N', and UPLO = 'U' */
if (notrans) {
/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 + 1], n);
zherk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda,
beta, &c__[n1 + 1], n);
zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[n2 + a_dim1], lda, &cbeta, &c__[1], n);
} else {
/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 + 1], n);
zherk_("U", "C", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda,
beta, &c__[n1 + 1], n);
zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[n2 * a_dim1 + 1], lda, &cbeta, &c__[1], n);
}
}
} else {
/* N is odd, and TRANSR = 'C' */
if (lower) {
/* N is odd, TRANSR = 'C', and UPLO = 'L' */
if (notrans) {
/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], &n1);
zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
beta, &c__[2], &n1);
zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[n1 + 1 + a_dim1], lda, &cbeta, &c__[n1 *
n1 + 1], &n1);
} else {
/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], &n1);
zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
lda, beta, &c__[2], &n1);
zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[(n1 + 1) * a_dim1 + 1], lda, &cbeta, &c__[
n1 * n1 + 1], &n1);
}
} else {
/* N is odd, TRANSR = 'C', and UPLO = 'U' */
if (notrans) {
/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 * n2 + 1], &n2);
zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
beta, &c__[n1 * n2 + 1], &n2);
zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &n2);
} else {
/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 * n2 + 1], &n2);
zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
lda, beta, &c__[n1 * n2 + 1], &n2);
zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[1], &n2);
}
}
}
} else {
/* N is even */
if (normaltransr) {
/* N is even and TRANSR = 'N' */
if (lower) {
/* N is even, TRANSR = 'N', and UPLO = 'L' */
if (notrans) {
/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
i__1 = *n + 1;
zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[2], &i__1);
i__1 = *n + 1;
zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[1], &i__1);
i__1 = *n + 1;
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[nk + 2],
&i__1);
} else {
/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
i__1 = *n + 1;
zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[2], &i__1);
i__1 = *n + 1;
zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[1], &i__1);
i__1 = *n + 1;
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[nk + 2], &i__1);
}
} else {
/* N is even, TRANSR = 'N', and UPLO = 'U' */
if (notrans) {
/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
i__1 = *n + 1;
zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 2], &i__1);
i__1 = *n + 1;
zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[nk + 1], &i__1);
i__1 = *n + 1;
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[1], &
i__1);
} else {
/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
i__1 = *n + 1;
zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 2], &i__1);
i__1 = *n + 1;
zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[nk + 1], &i__1);
i__1 = *n + 1;
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
1], &i__1);
}
}
} else {
/* N is even, and TRANSR = 'C' */
if (lower) {
/* N is even, TRANSR = 'C', and UPLO = 'L' */
if (notrans) {
/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 1], &nk);
zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[1], &nk);
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[(nk +
1) * nk + 1], &nk);
} else {
/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 1], &nk);
zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[1], &nk);
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
(nk + 1) * nk + 1], &nk);
}
} else {
/* N is even, TRANSR = 'C', and UPLO = 'U' */
if (notrans) {
/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk * (nk + 1) + 1], &nk);
zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[nk * nk + 1], &nk);
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &nk);
} else {
/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk * (nk + 1) + 1], &nk);
zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[nk * nk + 1], &nk);
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[1], &nk);
}
}
}
}
return 0;
/* End of ZHFRK */
} /* zhfrk_ */
/* Subroutine */ int zget51_(integer *itype, integer *n, doublecomplex *a,
integer *lda, doublecomplex *b, integer *ldb, doublecomplex *u,
integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *work,
doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, u_dim1, u_offset, v_dim1,
v_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
doublereal ulp;
integer jcol;
doublereal unfl;
integer jrow, jdiag;
doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
doublereal wnorm;
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGET51 generally checks a decomposition of the form */
/* A = U B V* */
/* where * means conjugate transpose and U and V are unitary. */
/* Specifically, if ITYPE=1 */
/* RESULT = | A - U B V* | / ( |A| n ulp ) */
/* If ITYPE=2, then: */
/* RESULT = | A - B | / ( |A| n ulp ) */
/* If ITYPE=3, then: */
/* RESULT = | I - UU* | / ( n ulp ) */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the type of tests to be performed. */
/* =1: RESULT = | A - U B V* | / ( |A| n ulp ) */
/* =2: RESULT = | A - B | / ( |A| n ulp ) */
/* =3: RESULT = | I - UU* | / ( n ulp ) */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, ZGET51 does nothing. */
/* It must be at least zero. */
/* A (input) COMPLEX*16 array, dimension (LDA, N) */
/* The original (unfactored) matrix. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least N. */
/* B (input) COMPLEX*16 array, dimension (LDB, N) */
/* The factored matrix. */
/* LDB (input) INTEGER */
/* The leading dimension of B. It must be at least 1 */
/* and at least N. */
/* U (input) COMPLEX*16 array, dimension (LDU, N) */
/* The unitary matrix on the left-hand side in the */
/* decomposition. */
/* Not referenced if ITYPE=2 */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N and */
/* at least 1. */
/* V (input) COMPLEX*16 array, dimension (LDV, N) */
/* The unitary matrix on the left-hand side in the */
/* decomposition. */
/* Not referenced if ITYPE=2 */
/* LDV (input) INTEGER */
/* The leading dimension of V. LDV must be at least N and */
/* at least 1. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N**2) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESULT (output) DOUBLE PRECISION */
/* The values computed by the test specified by ITYPE. The */
/* value is currently limited to 1/ulp, to avoid overflow. */
/* Errors are flagged by RESULT=10/ulp. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
--rwork;
/* Function Body */
*result = 0.;
if (*n <= 0) {
return 0;
}
/* Constants */
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
*result = 10. / ulp;
return 0;
}
if (*itype <= 2) {
/* Tests scaled by the norm(A) */
/* Computing MAX */
d__1 = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
if (*itype == 1) {
/* ITYPE=1: Compute W = A - UBV' */
zlacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
/* Computing 2nd power */
i__1 = *n;
zgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &b[b_offset],
ldb, &c_b1, &work[i__1 * i__1 + 1], n);
z__1.r = -1., z__1.i = -0.;
/* Computing 2nd power */
i__1 = *n;
zgemm_("N", "C", n, n, n, &z__1, &work[i__1 * i__1 + 1], n, &v[
v_offset], ldv, &c_b2, &work[1], n);
} else {
/* ITYPE=2: Compute W = A - B */
zlacpy_(" ", n, n, &b[b_offset], ldb, &work[1], n);
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L10: */
}
/* L20: */
}
}
/* Compute norm(W)/ ( ulp*norm(A) ) */
wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
if (anorm > wnorm) {
*result = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
*result = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
*result = min(d__1,d__2) / (*n * ulp);
}
}
} else {
/* Tests not scaled by norm(A) */
/* ITYPE=3: Compute UU' - I */
zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
&c_b1, &work[1], n);
i__1 = *n;
for (jdiag = 1; jdiag <= i__1; ++jdiag) {
i__2 = (*n + 1) * (jdiag - 1) + 1;
i__3 = (*n + 1) * (jdiag - 1) + 1;
z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L30: */
}
/* Computing MIN */
d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
doublereal) (*n);
*result = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of ZGET51 */
} /* zget51_ */
/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, doublecomplex *v, integer
*ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *
ldc, doublecomplex *work, integer *ldwork)
{
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *);
integer lastc;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer lastv;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrmm_(char *, char *, char *, char *
, integer *, integer *, doublecomplex *, doublecomplex *, integer
*, doublecomplex *, integer *);
extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
;
extern integer ilazlr_(integer *, integer *, doublecomplex *, integer *);
char transt[1];
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFB applies a complex block reflector H or its transpose H' to a */
/* complex M-by-N matrix C, from either the left or the right. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply H or H' from the Left */
/* = 'R': apply H or H' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply H (No transpose) */
/* = 'C': apply H' (Conjugate transpose) */
/* DIRECT (input) CHARACTER*1 */
/* Indicates how H is formed from a product of elementary */
/* reflectors */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Indicates how the vectors which define the elementary */
/* reflectors are stored: */
/* = 'C': Columnwise */
/* = 'R': Rowwise */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* K (input) INTEGER */
/* The order of the matrix T (= the number of elementary */
/* reflectors whose product defines the block reflector). */
/* V (input) COMPLEX*16 array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
/* if STOREV = 'R', LDV >= K. */
/* T (input) COMPLEX*16 array, dimension (LDT,K) */
/* The triangular K-by-K matrix T in the representation of the */
/* block reflector. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* If SIDE = 'L', LDWORK >= max(1,N); */
/* if SIDE = 'R', LDWORK >= max(1,M). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (lsame_(trans, "N")) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(storev, "C")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 ) (first K rows) */
/* ( V2 ) */
/* where V1 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L10: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C2'*V2 */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k +
1 + v_dim1], ldv, &c_b1, &work[work_offset],
ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (*m > *k) {
/* C2 := C2 - V2 * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &
lastc, k, &z__1, &v[*k + 1 + v_dim1], ldv, &work[
work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1]
, ldc);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L20: */
}
/* L30: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L40: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C2 * V2 */
i__1 = lastv - *k;
zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1
+ v_dim1], ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (lastv > *k) {
/* C2 := C2 - W * V2' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &lastc, &
i__1, k, &z__1, &work[work_offset], ldwork, &v[*k
+ 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1
+ 1], ldc);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L50: */
}
/* L60: */
}
}
} else {
/* Let V = ( V1 ) */
/* ( V2 ) (last K rows) */
/* where V2 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
j * work_dim1 + 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L70: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1'*V1 */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (lastv > *k) {
/* C1 := C1 - V1 * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &
lastc, k, &z__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
work[work_offset], ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = lastv - *k + j + i__ * c_dim1;
i__4 = lastv - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L80: */
}
/* L90: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
&work[j * work_dim1 + 1], &c__1);
/* L100: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1 * V1 */
i__1 = lastv - *k;
zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (lastv > *k) {
/* C1 := C1 - W * V1' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &lastc, &
i__1, k, &z__1, &work[work_offset], ldwork, &v[
v_offset], ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
work[work_offset], ldwork);
/* C2 := C2 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (lastv - *k + j) * c_dim1;
i__4 = i__ + (lastv - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L110: */
}
/* L120: */
}
}
}
} else if (lsame_(storev, "R")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 V2 ) (V1: first K columns) */
/* where V1 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L130: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
if (lastv > *k) {
/* W := W + C2'*V2' */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", &
lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1],
ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (lastv > *k) {
/* C2 := C2 - V2' * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, &lastc, k, &z__1, &v[(*k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork, &c_b1, &c__[*k
+ 1 + c_dim1], ldc);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L140: */
}
/* L150: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L160: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
if (lastv > *k) {
/* W := W + C2 * V2' */
i__1 = lastv - *k;
zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[
(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (lastv > *k) {
/* C2 := C2 - W * V2 */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
z__1, &work[work_offset], ldwork, &v[(*k + 1) *
v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 +
1], ldc);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L170: */
}
/* L180: */
}
}
} else {
/* Let V = ( V1 V2 ) (V2: last K columns) */
/* where V2 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
j * work_dim1 + 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L190: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1'*V1' */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", &
lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[
v_offset], ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (lastv > *k) {
/* C1 := C1 - V1' * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, &lastc, k, &z__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = lastv - *k + j + i__ * c_dim1;
i__4 = lastv - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L200: */
}
/* L210: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
&work[j * work_dim1 + 1], &c__1);
/* L220: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1 * V1' */
i__1 = lastv - *k;
zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (lastv > *k) {
/* C1 := C1 - W * V1 */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
z__1, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (lastv - *k + j) * c_dim1;
i__4 = i__ + (lastv - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of ZLARFB */
} /* zlarfb_ */
/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer
*nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt,
doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *
auxv, doublecomplex *f, integer *ldf)
{
/* System generated locals */
integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
integer i_dnnt(doublereal *);
/* Local variables */
integer j, k, rk;
doublecomplex akk;
integer pvt;
doublereal temp, temp2, tol3z;
integer itemp;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
extern integer idamax_(integer *, doublereal *, integer *);
integer lsticc;
extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
integer lastrk;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQPS computes a step of QR factorization with column pivoting */
/* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */
/* NB columns from A starting from the row OFFSET+1, and updates all */
/* of the matrix with Blas-3 xGEMM. */
/* In some cases, due to catastrophic cancellations, it cannot */
/* factorize NB columns. Hence, the actual number of factorized */
/* columns is returned in KB. */
/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0 */
/* OFFSET (input) INTEGER */
/* The number of rows of A that have been factorized in */
/* previous steps. */
/* NB (input) INTEGER */
/* The number of columns to factorize. */
/* KB (output) INTEGER */
/* The number of columns actually factorized. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
/* factor obtained and block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
/* been updated. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* JPVT(I) = K <==> Column K of the full matrix A has been */
/* permuted into position I in AP. */
/* TAU (output) COMPLEX*16 array, dimension (KB) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the exact column norms. */
/* AUXV (input/output) COMPLEX*16 array, dimension (NB) */
/* Auxiliar vector. */
/* F (input/output) COMPLEX*16 array, dimension (LDF,NB) */
/* Matrix F' = L*Y'*A. */
/* LDF (input) INTEGER */
/* The leading dimension of the array F. LDF >= max(1,N). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--auxv;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
/* Computing MIN */
i__1 = *m, i__2 = *n + *offset;
lastrk = min(i__1,i__2);
lsticc = 0;
k = 0;
tol3z = sqrt(dlamch_("Epsilon"));
/* Beginning of while loop. */
L10:
if (k < *nb && lsticc == 0) {
++k;
rk = *offset + k;
/* Determine ith pivot column and swap if necessary */
i__1 = *n - k + 1;
pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1);
if (pvt != k) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
zswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[k];
jpvt[k] = itemp;
vn1[pvt] = vn1[k];
vn2[pvt] = vn2[k];
}
/* Apply previous Householder reflectors to column K: */
/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
if (k > 1) {
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L20: */
}
i__1 = *m - rk + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1], lda,
&f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L30: */
}
}
/* Generate elementary reflector H(k). */
if (rk < *m) {
i__1 = *m - rk + 1;
zlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
c__1, &tau[k]);
} else {
zlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
tau[k]);
}
i__1 = rk + k * a_dim1;
akk.r = a[i__1].r, akk.i = a[i__1].i;
i__1 = rk + k * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
/* Compute Kth column of F: */
/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
if (k < *n) {
i__1 = *m - rk + 1;
i__2 = *n - k;
zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k +
1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
k + 1 + k * f_dim1], &c__1);
}
/* Padding F(1:K,K) with zeros. */
i__1 = k;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * f_dim1;
f[i__2].r = 0., f[i__2].i = 0.;
/* L40: */
}
/* Incremental updating of F: */
/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
/* *A(RK:M,K). */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
i__3 = k;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1]
, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);
i__1 = k - 1;
zgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
}
/* Update the current row of A: */
/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
z__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
c_b2, &a[rk + (k + 1) * a_dim1], lda);
}
/* Update partial column norms. */
if (rk < lastrk) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
if (vn1[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = z_abs(&a[rk + j * a_dim1]) / vn1[j];
/* Computing MAX */
d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
temp = max(d__1,d__2);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
vn2[j] = (doublereal) lsticc;
lsticc = j;
} else {
vn1[j] *= sqrt(temp);
}
}
/* L50: */
}
}
i__1 = rk + k * a_dim1;
a[i__1].r = akk.r, a[i__1].i = akk.i;
/* End of while loop. */
goto L10;
}
*kb = k;
rk = *offset + *kb;
/* Apply the block reflector to the rest of the matrix: */
/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
/* Computing MIN */
i__1 = *n, i__2 = *m - *offset;
if (*kb < min(i__1,i__2)) {
i__1 = *m - rk;
i__2 = *n - *kb;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1,
&a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
a[rk + 1 + (*kb + 1) * a_dim1], lda);
}
/* Recomputation of difficult columns. */
L60:
if (lsticc > 0) {
itemp = i_dnnt(&vn2[lsticc]);
i__1 = *m - rk;
vn1[lsticc] = dznrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
/* SNRM2 does not fail on vectors with norm below the value of */
/* SQRT(DLAMCH('S')) */
vn2[lsticc] = vn1[lsticc];
lsticc = itemp;
goto L60;
}
return 0;
/* End of ZLAQPS */
} /* zlaqps_ */
void
zgstrs (trans_t trans, SuperMatrix *L, SuperMatrix *U,
int *perm_c, int *perm_r, SuperMatrix *B,
SuperLUStat_t *stat, int *info)
{
/*
* Purpose
* =======
*
* ZGSTRS solves a system of linear equations A*X=B or A'*X=B
* with A sparse and B dense, using the LU factorization computed by
* ZGSTRF.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* trans (input) trans_t
* Specifies the form of the system of equations:
* = NOTRANS: A * X = B (No transpose)
* = TRANS: A'* X = B (Transpose)
* = CONJ: A**H * X = B (Conjugate transpose)
*
* L (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U as computed by
* zgstrf(). Use compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SLU_SC, Dtype = SLU_Z, Mtype = SLU_TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* zgstrf(). Use column-wise storage scheme, i.e., U has types:
* Stype = SLU_NC, Dtype = SLU_Z, Mtype = SLU_TRU.
*
* perm_c (input) int*, dimension (L->ncol)
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
*
* perm_r (input) int*, dimension (L->nrow)
* Row permutation vector, which defines the permutation matrix Pr;
* perm_r[i] = j means row i of A is in position j in Pr*A.
*
* B (input/output) SuperMatrix*
* B has types: Stype = SLU_DN, Dtype = SLU_Z, Mtype = SLU_GE.
* On entry, the right hand side matrix.
* On exit, the solution matrix if info = 0;
*
* stat (output) SuperLUStat_t*
* Record the statistics on runtime and floating-point operation count.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
*
*/
#ifdef _CRAY
_fcd ftcs1, ftcs2, ftcs3, ftcs4;
#endif
int incx = 1, incy = 1;
#ifdef USE_VENDOR_BLAS
doublecomplex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
doublecomplex *work_col;
#endif
doublecomplex temp_comp;
DNformat *Bstore;
doublecomplex *Bmat;
SCformat *Lstore;
NCformat *Ustore;
doublecomplex *Lval, *Uval;
int fsupc, nrow, nsupr, nsupc, luptr, istart, irow;
int i, j, k, iptr, jcol, n, ldb, nrhs;
doublecomplex *work, *rhs_work, *soln;
flops_t solve_ops;
void zprint_soln();
/* Test input parameters ... */
*info = 0;
Bstore = B->Store;
ldb = Bstore->lda;
nrhs = B->ncol;
if ( trans != NOTRANS && trans != TRANS && trans != CONJ ) *info = -1;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SLU_SC || L->Dtype != SLU_Z || L->Mtype != SLU_TRLU )
*info = -2;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != SLU_NC || U->Dtype != SLU_Z || U->Mtype != SLU_TRU )
*info = -3;
else if ( ldb < SUPERLU_MAX(0, L->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_Z || B->Mtype != SLU_GE )
*info = -6;
if ( *info ) {
i = -(*info);
xerbla_("zgstrs", &i);
return;
}
n = L->nrow;
work = doublecomplexCalloc(n * nrhs);
if ( !work ) ABORT("Malloc fails for local work[].");
soln = doublecomplexMalloc(n);
if ( !soln ) ABORT("Malloc fails for local soln[].");
Bmat = Bstore->nzval;
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( trans == NOTRANS ) {
/* Permute right hand sides to form Pr*B */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_r[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
/* Forward solve PLy=Pb. */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
nrow = nsupr - nsupc;
solve_ops += 4 * nsupc * (nsupc - 1) * nrhs;
solve_ops += 8 * nrow * nsupc * nrhs;
if ( nsupc == 1 ) {
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
luptr = L_NZ_START(fsupc);
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); iptr++){
irow = L_SUB(iptr);
++luptr;
zz_mult(&temp_comp, &rhs_work[fsupc], &Lval[luptr]);
z_sub(&rhs_work[irow], &rhs_work[irow], &temp_comp);
}
}
} else {
luptr = L_NZ_START(fsupc);
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSM( ftcs1, ftcs1, ftcs2, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
CGEMM( ftcs2, ftcs2, &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#else
ztrsm_("L", "L", "N", "U", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
zgemm_( "N", "N", &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#endif
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
work_col = &work[j*n];
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
z_sub(&rhs_work[irow], &rhs_work[irow], &work_col[i]);
work_col[i].r = 0.0;
work_col[i].i = 0.0;
iptr++;
}
}
#else
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
zlsolve (nsupr, nsupc, &Lval[luptr], &rhs_work[fsupc]);
zmatvec (nsupr, nrow, nsupc, &Lval[luptr+nsupc],
&rhs_work[fsupc], &work[0] );
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
z_sub(&rhs_work[irow], &rhs_work[irow], &work[i]);
work[i].r = 0.;
work[i].i = 0.;
iptr++;
}
}
#endif
} /* else ... */
} /* for L-solve */
#ifdef DEBUG
printf("After L-solve: y=\n");
zprint_soln(n, nrhs, Bmat);
#endif
/*
* Back solve Ux=y.
*/
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 4 * nsupc * (nsupc + 1) * nrhs;
if ( nsupc == 1 ) {
rhs_work = &Bmat[0];
for (j = 0; j < nrhs; j++) {
z_div(&rhs_work[fsupc], &rhs_work[fsupc], &Lval[luptr]);
rhs_work += ldb;
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("U", strlen("U"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSM( ftcs1, ftcs2, ftcs3, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#else
ztrsm_("L", "U", "N", "N", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#endif
#else
for (j = 0; j < nrhs; j++)
zusolve ( nsupr, nsupc, &Lval[luptr], &Bmat[fsupc+j*ldb] );
#endif
}
for (j = 0; j < nrhs; ++j) {
rhs_work = &Bmat[j*ldb];
for (jcol = fsupc; jcol < fsupc + nsupc; jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++ ){
irow = U_SUB(i);
zz_mult(&temp_comp, &rhs_work[jcol], &Uval[i]);
z_sub(&rhs_work[irow], &rhs_work[irow], &temp_comp);
}
}
}
} /* for U-solve */
#ifdef DEBUG
printf("After U-solve: x=\n");
zprint_soln(n, nrhs, Bmat);
#endif
/* Compute the final solution X := Pc*X. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_c[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = solve_ops;
} else { /* Solve A'*X=B */
/* Permute right hand sides to form Pc'*B. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_c[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = 0;
if (trans == TRANS) {
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_ztrsv("U", "T", "N", L, U, &Bmat[k*ldb], stat, info);
/* Multiply by inv(L'). */
sp_ztrsv("L", "T", "U", L, U, &Bmat[k*ldb], stat, info);
}
}
else {
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_ztrsv("U", "C", "N", L, U, &Bmat[k*ldb], stat, info);
/* Multiply by inv(L'). */
sp_ztrsv("L", "C", "U", L, U, &Bmat[k*ldb], stat, info);
}
}
/* Compute the final solution X := Pr'*X (=inv(Pr)*X) */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_r[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
}
SUPERLU_FREE(work);
SUPERLU_FREE(soln);
}
/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,d12.3)";
static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9992[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9991[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
doublecomplex a[2500] /* was [50][50] */, b[2500] /* was [50][
50] */, e[2500] /* was [50][50] */, f[2500] /* was [50][
50] */;
integer i__, j, m, n;
doublecomplex af[2500] /* was [50][50] */, bf[2500] /* was [50][
50] */, vl[2500] /* was [50][50] */, vr[2500] /* was [50][
50] */;
integer ihi, ilo;
doublereal eps;
doublecomplex vlf[2500] /* was [50][50] */;
integer knt;
doublecomplex vrf[2500] /* was [50][50] */;
integer info, lmax[4];
doublereal rmax, vmax;
doublecomplex work[2500] /* was [50][50] */;
integer ninfo;
doublereal anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
doublereal rwork[300];
extern doublereal dlamch_(char *);
doublereal lscale[50];
extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zggbal_(char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal rscale[50];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGK tests ZGGBAK, a routine for backward balancing of */
/* a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L50: */
}
++knt;
anorm = zlange_("M", &n, &n, a, &c__50, rwork);
bnorm = zlange_("M", &n, &n, b, &c__50, rwork);
zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork,
&info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of ZGGBAK */
/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
/* where tilde(A) denotes the transformed matrix. */
zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 50 - 51;
i__4 = i__ + j * 50 - 51;
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L60: */
}
/* L70: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 50 - 51;
i__4 = i__ + j * 50 - 51;
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L80: */
}
/* L90: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___35.ciunit = *nout;
s_wsfe(&io___35);
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGK */
} /* zchkgk_ */
/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1,
doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex *
z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3,
doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty,
doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau,
doublecomplex *work, integer *nwork, doublereal *rwork, integer *
iwork, logical *select, doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 ZCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 ZCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j, k, n, n1, jj, in, ihi, ilo;
doublereal ulp, cond;
integer jcol, nmax;
doublereal unfl, ovfl, temp1, temp2;
logical badnn, match;
integer imode;
doublereal dumma[4];
integer iinfo;
doublereal conds;
extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *);
doublereal aninv, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer nmats, jsize, nerrs, itype, jtype, ntest;
extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublecomplex cdumma[4];
integer idumma[1];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), dlasum_(
char *, integer *, integer *, integer *), zlatme_(integer
*, char *, integer *, doublecomplex *, integer *, doublereal *,
doublecomplex *, char *, char *, char *, char *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublecomplex *, doublereal *, integer *, integer *,
integer *), zlacpy_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatmr_(
integer *, integer *, char *, integer *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *);
doublereal rtunfl, rtovfl, rtulpi, ulpinv;
integer mtypes, ntestt;
extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrevc_(char
*, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zunmhr_(char *, char *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKHS checks the nonsymmetric eigenvalue problem routines. */
/* ZGEHRD factors A as U H U' , where ' means conjugate */
/* transpose, H is hessenberg, and U is unitary. */
/* ZUNGHR generates the unitary matrix U. */
/* ZUNMHR multiplies a matrix by the unitary matrix U. */
/* ZHSEQR factors H as Z T Z' , where Z is unitary and T */
/* is upper triangular. It also computes the eigenvalues, */
/* w(1), ..., w(n); we define a diagonal matrix W whose */
/* (diagonal) entries are the eigenvalues. */
/* ZTREVC computes the left eigenvector matrix L and the */
/* right eigenvector matrix R for the matrix T. The */
/* columns of L are the complex conjugates of the left */
/* eigenvectors of T. The columns of R are the right */
/* eigenvectors of T. L is lower triangular, and R is */
/* upper triangular. */
/* ZHSEIN computes the left eigenvector matrix Y and the */
/* right eigenvector matrix X for the matrix H. The */
/* columns of Y are the complex conjugates of the left */
/* eigenvectors of H. The columns of X are the right */
/* eigenvectors of H. Y is lower triangular, and X is */
/* upper triangular. */
/* When ZCHKHS is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
/* tests will be performed: */
/* (1) | A - U H U**H | / ( |A| n ulp ) */
/* (2) | I - UU**H | / ( n ulp ) */
/* (3) | H - Z T Z**H | / ( |H| n ulp ) */
/* (4) | I - ZZ**H | / ( n ulp ) */
/* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */
/* (6) | I - UZ (UZ)**H | / ( n ulp ) */
/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
/* (9) | TR - RW | / ( |T| |R| ulp ) */
/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
/* (11) | HX - XW | / ( |H| |X| ulp ) */
/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
/* (13) | AX - XW | / ( |A| |X| ulp ) */
/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========== */
/* NSIZES - INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZCHKHS does nothing. It must be at least zero. */
/* Not modified. */
/* NN - INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* Not modified. */
/* NTYPES - INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZCHKHS */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* Not modified. */
/* DOTYPE - LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* Not modified. */
/* ISEED - INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZCHKHS to continue the same random number */
/* sequence. */
/* Modified. */
/* THRESH - DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* Not modified. */
/* NOUNIT - INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* Not modified. */
/* A - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually */
/* used. */
/* Modified. */
/* LDA - INTEGER */
/* The leading dimension of A, H, T1 and T2. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* H - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The upper hessenberg matrix computed by ZGEHRD. On exit, */
/* H contains the Hessenberg form of the matrix in A. */
/* Modified. */
/* T1 - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The Schur (="quasi-triangular") matrix computed by ZHSEQR */
/* if Z is computed. On exit, T1 contains the Schur form of */
/* the matrix in A. */
/* Modified. */
/* T2 - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The Schur matrix computed by ZHSEQR when Z is not computed. */
/* This should be identical to T1. */
/* Modified. */
/* LDU - INTEGER */
/* The leading dimension of U, Z, UZ and UU. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* U - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by ZGEHRD. */
/* Modified. */
/* Z - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by ZHSEQR. */
/* Modified. */
/* UZ - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The product of U times Z. */
/* Modified. */
/* W1 - COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a full Schur */
/* decomposition H = Z T Z'. On exit, W1 contains the */
/* eigenvalues of the matrix in A. */
/* Modified. */
/* W3 - COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a partial Schur */
/* decomposition (Z not computed, T only computed as much */
/* as is necessary for determining eigenvalues). On exit, */
/* W3 contains the eigenvalues of the matrix in A, possibly */
/* perturbed by ZHSEIN. */
/* Modified. */
/* EVECTL - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the (upper triangular) left */
/* eigenvector matrix for the matrix in T1. */
/* Modified. */
/* EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The (upper triangular) right eigenvector matrix for the */
/* matrix in T1. */
/* Modified. */
/* EVECTY - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the left eigenvector matrix */
/* for the matrix in H. */
/* Modified. */
/* EVECTX - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The right eigenvector matrix for the matrix in H. */
/* Modified. */
/* UU - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* Details of the unitary matrix computed by ZGEHRD. */
/* Modified. */
/* TAU - COMPLEX*16 array, dimension (max(NN)) */
/* Further details of the unitary matrix computed by ZGEHRD. */
/* Modified. */
/* WORK - COMPLEX*16 array, dimension (NWORK) */
/* Workspace. */
/* Modified. */
/* NWORK - INTEGER */
/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
/* RWORK - DOUBLE PRECISION array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not SELECT. */
/* Modified. */
/* IWORK - INTEGER array, dimension (max(NN)) */
/* Workspace. */
/* Modified. */
/* SELECT - LOGICAL array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not RWORK. */
/* Modified. */
/* RESULT - DOUBLE PRECISION array, dimension (14) */
/* The values computed by the fourteen tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* Modified. */
/* INFO - INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDU < 1 or LDU < NMAX. */
/* -26: NWORK too small. */
/* If ZLATMR, CLATMS, or CLATME returns an error code, the */
/* absolute value of it is returned. */
/* If 1, then ZHSEQR could not find all the shifts. */
/* If 2, then the EISPACK code (for small blocks) failed. */
/* If >2, then 30*N iterations were not enough to find an */
/* eigenvalue or to decompose the problem. */
/* Modified. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* MTEST The number of tests defined: care must be taken */
/* that (1) the size of RESULT, (2) the number of */
/* tests actually performed, and (3) MTEST agree. */
/* NTEST The number of tests performed on this matrix */
/* so far. This should be less than MTEST, and */
/* equal to it by the last test. It will be less */
/* if any of the routines being tested indicates */
/* that it could not compute the matrices that */
/* would be tested. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far (computed by DLAFTS). */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL, */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selects whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--w1;
--w3;
--tau;
--work;
--rwork;
--iwork;
--select;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
aninv = 1. / (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L250;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.;
/* L30: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___35.ciunit = *nounit;
s_wsfe(&io___35);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call ZGEHRD to compute H and U, do tests. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
zgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___38.ciunit = *nounit;
s_wsfe(&io___38);
do_fio(&c__1, "ZGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = j + 1 + j * uu_dim1;
uu[i__4].r = 0., uu[i__4].i = 0.;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
i__5 = i__ + j * u_dim1;
i__6 = i__ + j * h_dim1;
u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
i__5 = i__ + j * uu_dim1;
i__6 = i__ + j * h_dim1;
uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
i__5 = i__ + j * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
/* L110: */
}
/* L120: */
}
i__3 = n - 1;
zcopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
zunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
/* Call ZHSEQR to compute T1, T2 and Z, do tests. */
/* Eigenvalues only (W3) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
zhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "ZHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L240;
}
}
/* Eigenvalues (W1) and Full Schur Form (T2) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
zhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "ZHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
zlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
zhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Compute Z = U' UZ */
zgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
/* and 4: | I - Z Z' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
zget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &rwork[1], &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.;
temp2 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
d__1 = temp1, d__2 = z_abs(&w1[j]), d__1 = max(d__1,d__2),
d__2 = z_abs(&w3[j]);
temp1 = max(d__1,d__2);
/* Computing MAX */
i__4 = j;
i__5 = j;
z__1.r = w1[i__4].r - w3[i__5].r, z__1.i = w1[i__4].i - w3[
i__5].i;
d__1 = temp2, d__2 = z_abs(&z__1);
temp2 = max(d__1,d__2);
/* L130: */
}
/* Computing MAX */
d__1 = unfl, d__2 = ulp * max(temp1,temp2);
result[8] = temp2 / max(d__1,d__2);
/* Compute the Left and Right Eigenvectors of T */
/* Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select every other eigenvector */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = FALSE_;
/* L140: */
}
i__3 = n;
for (j = 1; j <= i__3; j += 2) {
select[j] = TRUE_;
/* L150: */
}
ztrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
zget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that */
/* they agree with previous right eigenvectors */
ztrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "ZTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectr_dim1;
i__6 = jj + k * evectl_dim1;
if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
.i != evectl[i__6].i) {
match = FALSE_;
goto L180;
}
/* L160: */
}
++k;
}
/* L170: */
}
L180:
if (! match) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
ztrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "ZTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
zget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
2]);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that */
/* they agree with previous left eigenvectors */
ztrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "ZTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectl_dim1;
i__6 = jj + k * evectr_dim1;
if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
.i != evectr[i__6].i) {
match = FALSE_;
goto L210;
}
/* L190: */
}
++k;
}
/* L200: */
}
L210:
if (! match) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call ZHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L220: */
}
zhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "ZHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
/* (from inverse iteration) */
zget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call ZHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
zhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "ZHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
/* (from inverse iteration) */
zget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call ZUNMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
/* (from inverse iteration) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call ZUNMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
/* (from inverse iteration) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L240:
ntestt += ntest;
dlafts_("ZHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L250:
;
}
/* L260: */
}
/* Summary */
dlasum_("ZHS", nounit, &nerrs, &ntestt);
return 0;
/* End of ZCHKHS */
} /* zchkhs_ */
/* Subroutine */ int zpbtrf_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZPBTRF computes the Cholesky factorization of a complex Hermitian
positive definite band matrix A.
The factorization has the form
A = U**H * U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
Arguments
=========
UPLO (input) CHARACTER*1
= '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.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**H*U or A = L*L**H of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
Contributed by
Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
=====================================================================
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;
static doublereal c_b21 = -1.;
static doublereal c_b22 = 1.;
static integer c__33 = 33;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1;
/* Local variables */
static doublecomplex work[1056] /* was [33][32] */;
static 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 *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
static integer i2, i3;
extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zpbtf2_(char *, integer *, integer *, doublecomplex *, integer *,
integer *);
static integer ib, nb, ii, jj;
extern /* Subroutine */ int zpotf2_(char *, integer *, doublecomplex *,
integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
#define work_subscr(a_1,a_2) (a_2)*33 + a_1 - 34
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "ZPBTRF", uplo, n, kd, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
/* The block size must not exceed the semi-bandwidth KD, and must not
exceed the limit set by the size of the local array WORK. */
nb = min(nb,32);
if (nb <= 1 || nb > *kd) {
/* Use unblocked code */
zpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
} else {
/* Use blocked code */
if (lsame_(uplo, "U")) {
/* Compute the Cholesky factorization of a Hermitian band
matrix, given the upper triangle of the matrix in band
storage.
Zero the upper triangle of the work array. */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0., work[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
/* Process the band matrix one diagonal block at a time. */
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);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab_ref(*kd + 1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11 A12 A13
A22 A23
A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A12, A22 and
A23 are empty if IB = KD. The upper triangle of A13
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i2, &c_b1, &ab_ref(*kd + 1, i__),
&i__3, &ab_ref(*kd + 1 - ib, i__ + ib), &
i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i2, &ib, &
c_b21, &ab_ref(*kd + 1 - ib, i__ + ib), &i__3,
&c_b22, &ab_ref(*kd + 1, i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the lower triangle of A13 into the work array. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = work_subscr(ii, jj);
i__6 = ab_subscr(ii - jj + 1, jj + i__ + *kd
- 1);
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L30: */
}
/* L40: */
}
/* Update A13 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i3, &c_b1, &ab_ref(*kd + 1, i__),
&i__3, work, &c__33);
/* Update A23 */
if (i2 > 0) {
z__1.r = -1., z__1.i = 0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("Conjugate transpose", "No transpose", &i2,
&i3, &ib, &z__1, &ab_ref(*kd + 1 - ib,
i__ + ib), &i__3, work, &c__33, &c_b1, &
ab_ref(ib + 1, i__ + *kd), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i3, &ib, &
c_b21, work, &c__33, &c_b22, &ab_ref(*kd + 1,
i__ + *kd), &i__3);
/* Copy the lower triangle of A13 back into place. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = ab_subscr(ii - jj + 1, jj + i__ + *kd
- 1);
i__6 = work_subscr(ii, jj);
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L50: */
}
/* L60: */
}
}
}
/* L70: */
}
} else {
/* Compute the Cholesky factorization of a Hermitian band
matrix, given the lower triangle of the matrix in band
storage.
Zero the lower triangle of the work array. */
i__2 = nb;
for (j = 1; j <= i__2; ++j) {
i__1 = nb;
for (i__ = j + 1; i__ <= i__1; ++i__) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0., work[i__3].i = 0.;
/* L80: */
}
/* L90: */
}
/* Process the band matrix one diagonal block at a time. */
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);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab_ref(1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11
A21 A22
A31 A32 A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A21, A22 and
A32 are empty if IB = KD. The lower triangle of A31
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A21 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i2, &ib, &c_b1, &ab_ref(1, i__), &
i__3, &ab_ref(ib + 1, i__), &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Lower", "No transpose", &i2, &ib, &c_b21, &
ab_ref(ib + 1, i__), &i__3, &c_b22, &ab_ref(1,
i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the upper triangle of A31 into the work array. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = work_subscr(ii, jj);
i__6 = ab_subscr(*kd + 1 - jj + ii, jj + i__
- 1);
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L100: */
}
/* L110: */
}
/* Update A31 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i3, &ib, &c_b1, &ab_ref(1, i__), &
i__3, work, &c__33);
/* Update A32 */
if (i2 > 0) {
z__1.r = -1., z__1.i = 0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("No transpose", "Conjugate transpose", &i3,
&i2, &ib, &z__1, work, &c__33, &ab_ref(
ib + 1, i__), &i__3, &c_b1, &ab_ref(*kd +
1 - ib, i__ + ib), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Lower", "No transpose", &i3, &ib, &c_b21,
work, &c__33, &c_b22, &ab_ref(1, i__ + *kd), &
i__3);
/* Copy the upper triangle of A31 back into place. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = ab_subscr(*kd + 1 - jj + ii, jj + i__
- 1);
i__6 = work_subscr(ii, jj);
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L120: */
}
/* L130: */
}
}
}
/* L140: */
}
}
}
return 0;
L150:
return 0;
/* End of ZPBTRF */
} /* zpbtrf_ */
int zgetrf_(int *m, int *n, doublecomplex *a,
int *lda, int *ipiv, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Local variables */
int i__, j, jb, nb, iinfo;
extern int zgemm_(char *, char *, int *, int *,
int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, doublecomplex *,
int *), ztrsm_(char *, char *, char *, char *,
int *, int *, doublecomplex *, doublecomplex *, int *
, doublecomplex *, int *),
zgetf2_(int *, int *, doublecomplex *, int *, int
*, int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int zlaswp_(int *, doublecomplex *, int *,
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 */
/* ======= */
/* ZGETRF computes an LU factorization of a general M-by-N matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 3 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* IPIV (output) INTEGER array, dimension (MIN(M,N)) */
/* The pivot indices; for 1 <= i <= MIN(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGETRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZGETRF", " ", m, n, &c_n1, &c_n1);
if (nb <= 1 || nb >= MIN(*m,*n)) {
/* Use unblocked code. */
zgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
} else {
/* Use blocked code. */
i__1 = MIN(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = MIN(*m,*n) - j + 1;
jb = MIN(i__3,nb);
/* Factor diagonal and subdiagonal blocks and test for exact */
/* singularity. */
i__3 = *m - j + 1;
zgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
/* Adjust INFO and the pivot indices. */
if (*info == 0 && iinfo > 0) {
*info = iinfo + j - 1;
}
/* Computing MIN */
i__4 = *m, i__5 = j + jb - 1;
i__3 = MIN(i__4,i__5);
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = j - 1 + ipiv[i__];
/* L10: */
}
/* Apply interchanges to columns 1:J-1. */
i__3 = j - 1;
i__4 = j + jb - 1;
zlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
if (j + jb <= *n) {
/* Apply interchanges to columns J+JB:N. */
i__3 = *n - j - jb + 1;
i__4 = j + jb - 1;
zlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
ipiv[1], &c__1);
/* Compute block row of U. */
i__3 = *n - j - jb + 1;
ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
a_dim1], lda);
if (j + jb <= *m) {
/* Update trailing submatrix. */
i__3 = *m - j - jb + 1;
i__4 = *n - j - jb + 1;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", &i__3, &i__4, &jb,
&z__1, &a[j + jb + j * a_dim1], lda, &a[j + (j +
jb) * a_dim1], lda, &c_b1, &a[j + jb + (j + jb) *
a_dim1], lda);
}
}
/* L20: */
}
}
return 0;
/* End of ZGETRF */
} /* zgetrf_ */
/* Subroutine */ int zlqt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
l, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
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 *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLQT02 tests ZUNGLQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the LQ factorization of an m-by-n matrix A, ZLQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the first k */
/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
/* checks that the rows of Q are orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by ZLQT01. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the LQ factorization of A, as returned by ZGELQF. */
/* See ZGELQF for further details. */
/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* L (workspace) COMPLEX*16 array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the LQ factorization in AF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
i__1 = *n - 1;
zlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)6, (ftnlen)6);
zunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
zlaset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
zlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
zherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZLQT02 */
} /* zlqt02_ */
/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb,
doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
integer *ldw, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAHEF computes a partial factorization of a complex Hermitian
matrix A using the Bunch-Kaufman diagonal pivoting method. The
partial factorization has the form:
A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
( 0 U22 ) ( 0 D ) ( U12' U22' )
A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
( L21 I ) ( 0 A22 ) ( 0 I )
where the order of D is at most NB. The actual order is returned in
the argument KB, and is either NB or NB-1, or N if N <= NB.
Note that U' denotes the conjugate transpose of U.
ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code
(calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
A22 (if UPLO = 'L').
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
NB (input) INTEGER
The maximum number of columns of the matrix A that should be
factored. NB should be at least 2 to allow for 2-by-2 pivot
blocks.
KB (output) INTEGER
The number of columns of A that were actually factored.
KB is either NB-1 or NB, or N if N <= NB.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, A contains details of the partial factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D.
If UPLO = 'U', only the last KB elements of IPIV are set;
if UPLO = 'L', only the first KB elements are set.
If IPIV(k) > 0, then rows and columns k and IPIV(k) were
interchanged and D(k,k) is a 1-by-1 diagonal block.
If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
W (workspace) COMPLEX*16 array, dimension (LDW,NB)
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = k, D(k,k) is exactly zero. The factorization
has been completed, but the block diagonal matrix D is
exactly singular.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *,
doublecomplex *, doublecomplex *);
/* Local variables */
static integer imax, jmax, j, k;
static doublereal t, alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer kstep;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static doublereal r1;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
static doublecomplex d11, d21, d22;
static integer jb, jj, kk, jp, kp;
static doublereal absakk;
static integer kw;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal colmax;
extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
;
extern integer izamax_(integer *, doublecomplex *, integer *);
static doublereal rowmax;
static integer kkw;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define w_subscr(a_1,a_2) (a_2)*w_dim1 + a_1
#define w_ref(a_1,a_2) w[w_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (lsame_(uplo, "U")) {
/* Factorize the trailing columns of A using the upper triangle
of A and working backwards, and compute the matrix W = U12*D
for use in updating A11 (note that conjg(W) is actually stored)
K is the main loop index, decreasing from N in steps of 1 or 2
KW is the column of W which corresponds to column K of A */
k = *n;
L10:
kw = *nb + k - *n;
/* Exit from loop */
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
/* Copy column K of A to column KW of W and update it */
i__1 = k - 1;
zcopy_(&i__1, &a_ref(1, k), &c__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1), lda, &
w_ref(k, kw + 1), ldw, &c_b1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = w_subscr(k, kw);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = w_subscr(k, kw);
absakk = (d__1 = w[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(imax, kw);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, kw)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column KW-1 of W and update it */
i__1 = imax - 1;
zcopy_(&i__1, &a_ref(1, imax), &c__1, &w_ref(1, kw - 1), &
c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
i__1 = k - imax;
zcopy_(&i__1, &a_ref(imax, imax + 1), lda, &w_ref(imax + 1,
kw - 1), &c__1);
i__1 = k - imax;
zlacgv_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1),
lda, &w_ref(imax, kw + 1), ldw, &c_b1, &w_ref(1,
kw - 1), &c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = w_subscr(imax, kw - 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
i__1 = w_subscr(jmax, kw - 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, kw - 1)), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &w_ref(1, kw - 1), &c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, kw - 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, kw - 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, kw - 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
/* copy column KW-1 of W to column KW */
zcopy_(&k, &w_ref(1, kw - 1), &c__1, &w_ref(1, kw), &
c__1);
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
/* Updated column KP is already stored in column KKW of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kk - 1 - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp, kp + 1),
lda);
i__1 = kk - 1 - kp;
zlacgv_(&i__1, &a_ref(kp, kp + 1), lda);
i__1 = kp - 1;
zcopy_(&i__1, &a_ref(1, kk), &c__1, &a_ref(1, kp), &c__1);
/* Interchange rows KK and KP in last KK columns of A and W */
if (kk < *n) {
i__1 = *n - kk;
zswap_(&i__1, &a_ref(kk, kk + 1), lda, &a_ref(kp, kk + 1),
lda);
}
i__1 = *n - kk + 1;
zswap_(&i__1, &w_ref(kk, kkw), ldw, &w_ref(kp, kkw), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column KW of W now holds
W(k) = U(k)*D(k)
where U(k) is the k-th column of U
Store U(k) in column k of A */
zcopy_(&k, &w_ref(1, kw), &c__1, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = k - 1;
zdscal_(&i__1, &r1, &a_ref(1, k), &c__1);
/* Conjugate W(k) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
} else {
/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
hold
( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
where U(k) and U(k-1) are the k-th and (k-1)-th columns
of U */
if (k > 2) {
/* Store U(k) and U(k-1) in columns k and k-1 of A */
i__1 = w_subscr(k - 1, kw);
d21.r = w[i__1].r, d21.i = w[i__1].i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, kw), &z__2);
d11.r = z__1.r, d11.i = z__1.i;
z_div(&z__1, &w_ref(k - 1, kw - 1), &d21);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = a_subscr(j, k - 1);
i__3 = w_subscr(j, kw - 1);
z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, kw);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, kw);
z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, kw - 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L20: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k - 1, k - 1);
i__2 = w_subscr(k - 1, kw - 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k - 1, k);
i__2 = w_subscr(k - 1, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k-1) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
i__1 = k - 2;
zlacgv_(&i__1, &w_ref(1, kw - 1), &c__1);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
L30:
/* Update the upper triangle of A11 (= A(1:k,1:k)) as
A11 := A11 - U12*D*U12' = A11 - U12*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
i__1) {
/* Computing MIN */
i__2 = *nb, i__3 = k - j + 1;
jb = min(i__2,i__3);
/* Update the upper triangle of the diagonal block */
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
i__3 = jj - j + 1;
i__4 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__3, &i__4, &z__1, &a_ref(j, k + 1),
lda, &w_ref(jj, kw + 1), ldw, &c_b1, &a_ref(j, jj), &
c__1);
i__3 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &
a_ref(1, k + 1), lda, &w_ref(j, kw + 1), ldw, &c_b1, &
a_ref(1, j), lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchanges
in columns k+1:n */
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
zswap_(&i__1, &a_ref(jp, j), lda, &a_ref(jj, j), lda);
}
if (j <= *n) {
goto L60;
}
/* Set KB to the number of columns factorized */
*kb = *n - k;
} else {
/* Factorize the leading columns of A using the lower triangle
of A and working forwards, and compute the matrix W = L21*D
for use in updating A22 (note that conjg(W) is actually stored)
K is the main loop index, increasing from 1 in steps of 1 or 2 */
k = 1;
L70:
/* Exit from loop */
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
/* Copy column K of A to column K of W and update it */
i__1 = w_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &w_ref(k + 1, k), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda, &w_ref(
k, 1), ldw, &c_b1, &w_ref(k, k), &c__1);
i__1 = w_subscr(k, k);
i__2 = w_subscr(k, k);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = w_subscr(k, k);
absakk = (d__1 = w[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = w_subscr(imax, k);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, k)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column K+1 of W and update it */
i__1 = imax - k;
zcopy_(&i__1, &a_ref(imax, k), lda, &w_ref(k, k + 1), &c__1);
i__1 = imax - k;
zlacgv_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (imax < *n) {
i__1 = *n - imax;
zcopy_(&i__1, &a_ref(imax + 1, imax), &c__1, &w_ref(imax
+ 1, k + 1), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda,
&w_ref(imax, 1), ldw, &c_b1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = w_subscr(imax, k + 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(jmax, k + 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, k + 1)), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &w_ref(imax + 1, k + 1), &
c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, k + 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, k + 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, k + 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
/* copy column K+1 of W to column K */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k + 1), &c__1, &w_ref(k, k), &
c__1);
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
/* Updated column KP is already stored in column KK of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp - kk - 1;
zcopy_(&i__1, &a_ref(kk + 1, kk), &c__1, &a_ref(kp, kk + 1),
lda);
i__1 = kp - kk - 1;
zlacgv_(&i__1, &a_ref(kp, kk + 1), lda);
if (kp < *n) {
i__1 = *n - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp + 1,
kp), &c__1);
}
/* Interchange rows KK and KP in first KK columns of A and W */
i__1 = kk - 1;
zswap_(&i__1, &a_ref(kk, 1), lda, &a_ref(kp, 1), lda);
zswap_(&kk, &w_ref(kk, 1), ldw, &w_ref(kp, 1), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k of W now holds
W(k) = L(k)*D(k)
where L(k) is the k-th column of L
Store L(k) in column k of A */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k), &c__1, &a_ref(k, k), &c__1);
if (k < *n) {
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = *n - k;
zdscal_(&i__1, &r1, &a_ref(k + 1, k), &c__1);
/* Conjugate W(k) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
where L(k) and L(k+1) are the k-th and (k+1)-th columns
of L */
if (k < *n - 1) {
/* Store L(k) and L(k+1) in columns k and k+1 of A */
i__1 = w_subscr(k + 1, k);
d21.r = w[i__1].r, d21.i = w[i__1].i;
z_div(&z__1, &w_ref(k + 1, k + 1), &d21);
d11.r = z__1.r, d11.i = z__1.i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, k), &z__2);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, k);
z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, k + 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k + 1);
i__3 = w_subscr(j, k + 1);
z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, k);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L80: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k);
i__2 = w_subscr(k + 1, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k + 1);
i__2 = w_subscr(k + 1, k + 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k+1) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = *n - k - 1;
zlacgv_(&i__1, &w_ref(k + 2, k + 1), &c__1);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L70;
L90:
/* Update the lower triangle of A22 (= A(k:n,k:n)) as
A22 := A22 - L21*D*L21' = A22 - L21*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
i__1 = *n;
i__2 = *nb;
for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = *nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
/* Update the lower triangle of the diagonal block */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
i__4 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
i__4 = j + jb - jj;
i__5 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__4, &i__5, &z__1, &a_ref(jj, 1),
lda, &w_ref(jj, 1), ldw, &c_b1, &a_ref(jj, jj), &c__1);
i__4 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1,
&a_ref(j + jb, 1), lda, &w_ref(j, 1), ldw, &c_b1, &
a_ref(j + jb, j), lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchanges
in columns 1:k-1 */
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
zswap_(&j, &a_ref(jp, 1), lda, &a_ref(jj, 1), lda);
}
if (j >= 1) {
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of ZLAHEF */
} /* zlahef_ */
int zpotrf_(char *uplo, int *n, doublecomplex *a,
int *lda, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
int j, jb, nb;
extern int lsame_(char *, char *);
extern int zgemm_(char *, char *, int *, int *,
int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, doublecomplex *,
int *), zherk_(char *, char *, int *,
int *, double *, doublecomplex *, int *, double *,
doublecomplex *, int *);
int upper;
extern int ztrsm_(char *, char *, char *, char *,
int *, int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *),
zpotf2_(char *, int *, doublecomplex *, int *, 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 */
/* ======= */
/* ZPOTRF computes the Cholesky factorization of a complex Hermitian */
/* positive definite matrix A. */
/* The factorization has the form */
/* A = U**H * U, if UPLO = 'U', or */
/* A = L * L**H, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* This is the block version of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = '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 (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* N-by-N upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading N-by-N lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPOTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code. */
zpotf2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code. */
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Update and factorize the current diagonal block and test */
/* for non-positive-definiteness. */
/* Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = MIN(i__3,i__4);
i__3 = j - 1;
zherk_("Upper", "Conjugate transpose", &jb, &i__3, &c_b14, &a[
j * a_dim1 + 1], lda, &c_b15, &a[j + j * a_dim1], lda);
zpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block row. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "No transpose", &jb, &i__3,
&i__4, &z__1, &a[j * a_dim1 + 1], lda, &a[(j + jb)
* a_dim1 + 1], lda, &c_b1, &a[j + (j + jb) *
a_dim1], lda);
i__3 = *n - j - jb + 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit",
&jb, &i__3, &c_b1, &a[j + j * a_dim1], lda, &a[j
+ (j + jb) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__2 = *n;
i__1 = nb;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Update and factorize the current diagonal block and test */
/* for non-positive-definiteness. */
/* Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = MIN(i__3,i__4);
i__3 = j - 1;
zherk_("Lower", "No transpose", &jb, &i__3, &c_b14, &a[j +
a_dim1], lda, &c_b15, &a[j + j * a_dim1], lda);
zpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block column. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__3, &jb,
&i__4, &z__1, &a[j + jb + a_dim1], lda, &a[j +
a_dim1], lda, &c_b1, &a[j + jb + j * a_dim1], lda);
i__3 = *n - j - jb + 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non-unit"
, &i__3, &jb, &c_b1, &a[j + j * a_dim1], lda, &a[
j + jb + j * a_dim1], lda);
}
/* L20: */
}
}
}
goto L40;
L30:
*info = *info + j - 1;
L40:
return 0;
/* End of ZPOTRF */
} /* zpotrf_ */
/*< SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) >*/
/* Subroutine */ int zgehrd_(integer *n, integer *ilo, integer *ihi,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
integer i__;
doublecomplex t[4160] /* was [65][64] */;
integer ib;
doublecomplex ei;
integer nb, nh, nx=0, iws, nbmin, iinfo;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, ftnlen, ftnlen), zgehd2_(integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen),
zlahrd_(integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/*< INTEGER IHI, ILO, INFO, LDA, LWORK, N >*/
/* .. */
/* .. Array Arguments .. */
/*< COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H */
/* by a 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). */
/* ===================================================================== */
/* .. Parameters .. */
/*< INTEGER NBMAX, LDT >*/
/*< PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) >*/
/*< COMPLEX*16 ZERO, ONE >*/
/*< >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL LQUERY >*/
/*< >*/
/*< COMPLEX*16 EI >*/
/* .. */
/* .. Local Arrays .. */
/*< COMPLEX*16 T( LDT, NBMAX ) >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL XERBLA, ZGEHD2, ZGEMM, ZLAHRD, ZLARFB >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC MAX, MIN >*/
/* .. */
/* .. External Functions .. */
/*< INTEGER ILAENV >*/
/*< EXTERNAL ILAENV >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/*< INFO = 0 >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/*< NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) >*/
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1, (
ftnlen)6, (ftnlen)1);
nb = min(i__1,i__2);
/*< LWKOPT = N*NB >*/
lwkopt = *n * nb;
/*< WORK( 1 ) = LWKOPT >*/
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
/*< LQUERY = ( LWORK.EQ.-1 ) >*/
lquery = *lwork == -1;
/*< IF( N.LT.0 ) THEN >*/
if (*n < 0) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN >*/
} else if (*ilo < 1 || *ilo > max(1,*n)) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN >*/
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
/*< INFO = -3 >*/
*info = -3;
/*< ELSE IF( LDA.LT.MAX( 1, N ) ) THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = -5 >*/
*info = -5;
/*< ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN >*/
} else if (*lwork < max(1,*n) && ! lquery) {
/*< INFO = -8 >*/
*info = -8;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'ZGEHRD', -INFO ) >*/
i__1 = -(*info);
xerbla_("ZGEHRD", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< ELSE IF( LQUERY ) THEN >*/
} else if (lquery) {
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
/*< DO 10 I = 1, ILO - 1 >*/
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< TAU( I ) = ZERO >*/
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< DO 20 I = MAX( 1, IHI ), N - 1 >*/
i__1 = *n - 1;
for (i__ = max(1,*ihi); i__ <= i__1; ++i__) {
/*< TAU( I ) = ZERO >*/
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/*< 20 CONTINUE >*/
/* L20: */
}
/* Quick return if possible */
/*< NH = IHI - ILO + 1 >*/
nh = *ihi - *ilo + 1;
/*< IF( NH.LE.1 ) THEN >*/
if (nh <= 1) {
/*< WORK( 1 ) = 1 >*/
work[1].r = 1., work[1].i = 0.;
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< NBMIN = 2 >*/
nbmin = 2;
/*< IWS = 1 >*/
iws = 1;
/*< IF( NB.GT.1 .AND. NB.LT.NH ) THEN >*/
if (nb > 1 && nb < nh) {
/* Determine when to cross over from blocked to unblocked code */
/* (last block is always handled by unblocked code). */
/*< NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) >*/
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEHRD", " ", n, ilo, ihi, &c_n1, (
ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
/*< IF( NX.LT.NH ) THEN >*/
if (nx < nh) {
/* Determine if workspace is large enough for blocked code. */
/*< IWS = N*NB >*/
iws = *n * nb;
/*< IF( LWORK.LT.IWS ) THEN >*/
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, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1,i__2);
/*< IF( LWORK.GE.N*NBMIN ) THEN >*/
if (*lwork >= *n * nbmin) {
/*< NB = LWORK / N >*/
nb = *lwork / *n;
/*< ELSE >*/
} else {
/*< NB = 1 >*/
nb = 1;
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< LDWORK = N >*/
ldwork = *n;
/*< IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN >*/
if (nb < nbmin || nb >= nh) {
/* Use unblocked code below */
/*< I = ILO >*/
i__ = *ilo;
/*< ELSE >*/
} else {
/* Use blocked code */
/*< DO 30 I = ILO, IHI - 1 - NX, NB >*/
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/*< IB = MIN( NB, IHI-I ) >*/
/* 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 */
/*< >*/
zlahrd_(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. */
/*< EI = A( I+IB, I+IB-1 ) >*/
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
ei.r = a[i__3].r, ei.i = a[i__3].i;
/*< A( I+IB, I+IB-1 ) = ONE >*/
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, (ftnlen)12, (
ftnlen)19);
/*< A( I+IB, I+IB-1 ) = EI >*/
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(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, (ftnlen)4, (ftnlen)19, (ftnlen)7, (ftnlen)10);
/*< 30 CONTINUE >*/
/* L30: */
}
/*< END IF >*/
}
/* Use unblocked code to reduce the rest of the matrix */
/*< CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) >*/
zgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
/*< WORK( 1 ) = IWS >*/
work[1].r = (doublereal) iws, work[1].i = 0.;
/*< RETURN >*/
return 0;
/* End of ZGEHRD */
/*< END >*/
} /* zgehrd_ */
