int
f2c_zhpr2(char* uplo, integer* N,
doublecomplex* alpha,
doublecomplex* X, integer* incX,
doublecomplex* Y, integer* incY,
doublecomplex* Ap)
{
zhpr2_(uplo, N, alpha,
X, incX, Y, incY, Ap);
return 0;
}
void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
const integer N,const void *alpha, const void *X,
const integer incX,const void *Y, const integer incY, void *Ap)
{
char UL;
#ifdef F77_CHAR
F77_CHAR F77_UL;
#else
#define F77_UL &UL
#endif
#define F77_N N
#define F77_incX incx
#define F77_incY incy
integer n, i, j, incx=incX, incy=incY;
double *x=(double *)X, *xx=(double *)X, *y=(double *)Y,
*yy=(double *)Y, *stx, *sty;
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if (order == CblasColMajor)
{
if (Uplo == CblasLower) UL = 'L';
else if (Uplo == CblasUpper) UL = 'U';
else
{
cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo );
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
zhpr2_(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap);
} else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
if (N > 0)
{
n = N << 1;
x = malloc(n*sizeof(double));
y = malloc(n*sizeof(double));
stx = x + n;
sty = y + n;
if( incX > 0 )
i = incX << 1;
else
i = incX *(-2);
if( incY > 0 )
j = incY << 1;
else
j = incY *(-2);
do
{
*x = *xx;
x[1] = -xx[1];
x += 2;
xx += i;
} while (x != stx);
do
{
*y = *yy;
y[1] = -yy[1];
y += 2;
yy += j;
}
while (y != sty);
x -= n;
y -= n;
if(incX > 0 )
incx = 1;
else
incx = -1;
if(incY > 0 )
incy = 1;
else
incy = -1;
} else
{
x = (double *) X;
y = (void *) Y;
}
zhpr2_(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap);
}
else
{
cblas_xerbla(1, "cblas_zhpr2","Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if(X!=x)
free(x);
if(Y!=y)
free(y);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
/* Subroutine */
int zhptrd_(char *uplo, integer *n, doublecomplex *ap, doublereal *d__, doublereal *e, doublecomplex *tau, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, i1, ii, i1i1;
doublecomplex taui;
extern /* Subroutine */
int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *);
doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */
int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
if (upper)
{
/* Reduce the upper triangle of A. */
/* I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
i__1 = i1 + *n - 1;
i__2 = i1 + *n - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
for (i__ = *n - 1;
i__ >= 1;
--i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**H */
/* to annihilate A(1:i-1,i+1) */
i__1 = i1 + i__ - 1;
alpha.r = ap[i__1].r;
alpha.i = ap[i__1].i; // , expr subst
zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0. || taui.i != 0.)
{
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i1 + i__ - 1;
ap[i__1].r = 1.;
ap[i__1].i = 0.; // , expr subst
/* Compute y := tau * A * v storing y in TAU(1:i) */
zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[ 1], &c__1);
/* Compute w := y - 1/2 * tau * (y**H *v) * v */
z__3.r = -.5;
z__3.i = -0.; // , expr subst
z__2.r = z__3.r * taui.r - z__3.i * taui.i;
z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst
zdotc_f2c_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**H - w * v**H */
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[ 1]);
}
i__1 = i1 + i__ - 1;
i__2 = i__;
ap[i__1].r = e[i__2];
ap[i__1].i = 0.; // , expr subst
i__1 = i__ + 1;
i__2 = i1 + i__;
d__[i__1] = ap[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r;
tau[i__1].i = taui.i; // , expr subst
i1 -= i__;
/* L10: */
}
d__[1] = ap[1].r;
}
else
{
/* Reduce the lower triangle of A. II is the index in AP of */
/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
d__1 = ap[1].r;
ap[1].r = d__1;
ap[1].i = 0.; // , expr subst
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v**H */
/* to annihilate A(i+2:n,i) */
i__2 = ii + 1;
alpha.r = ap[i__2].r;
alpha.i = ap[i__2].i; // , expr subst
i__2 = *n - i__;
zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0. || taui.i != 0.)
{
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = ii + 1;
ap[i__2].r = 1.;
ap[i__2].i = 0.; // , expr subst
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & c_b2, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y**H *v) * v */
z__3.r = -.5;
z__3.i = -0.; // , expr subst
z__2.r = z__3.r * taui.r - z__3.i * taui.i;
z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst
i__2 = *n - i__;
zdotc_f2c_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**H - w * v**H */
i__2 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], & c__1, &ap[i1i1]);
}
i__2 = ii + 1;
i__3 = i__;
ap[i__2].r = e[i__3];
ap[i__2].i = 0.; // , expr subst
i__2 = i__;
i__3 = ii;
d__[i__2] = ap[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r;
tau[i__2].i = taui.i; // , expr subst
ii = i1i1;
/* L20: */
}
i__1 = *n;
i__2 = ii;
d__[i__1] = ap[i__2].r;
}
return 0;
/* End of ZHPTRD */
}
/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap,
doublereal *d__, doublereal *e, doublecomplex *tau, 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
=======
ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
real symmetric tridiagonal form T by a unitary similarity
transformation: Q**H * A * Q = T.
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.
AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, if UPLO = 'U', the diagonal and first superdiagonal
of A are overwritten by the corresponding elements of the
tridiagonal matrix T, and the elements above the first
superdiagonal, with the array TAU, represent the unitary
matrix Q as a product of elementary reflectors; if UPLO
= 'L', the diagonal and first subdiagonal of A are over-
written by the corresponding elements of the tridiagonal
matrix T, 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.
D (output) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal elements of the tridiagonal matrix T:
E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
TAU (output) COMPLEX*16 array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n-1) . . . H(2) H(1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(n-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 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
overwriting A(i+2:n,i), and tau is stored in TAU(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b2 = {0.,0.};
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
static doublecomplex taui;
extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *);
static integer i__;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer i1;
static logical upper;
extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static integer i1i1;
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A.
I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
i__1 = i1 + *n - 1;
i__2 = i1 + *n - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(1:i-1,i+1) */
i__1 = i1 + i__ - 1;
alpha.r = ap[i__1].r, alpha.i = ap[i__1].i;
zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i1 + i__ - 1;
ap[i__1].r = 1., ap[i__1].i = 0.;
/* Compute y := tau * A * v storing y in TAU(1:i) */
zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[
1], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
zdotc_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
z__1.r = -1., z__1.i = 0.;
zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[
1]);
}
i__1 = i1 + i__ - 1;
i__2 = i__;
ap[i__1].r = e[i__2], ap[i__1].i = 0.;
i__1 = i__ + 1;
i__2 = i1 + i__;
d__[i__1] = ap[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r, tau[i__1].i = taui.i;
i1 -= i__;
/* L10: */
}
d__[1] = ap[1].r;
} else {
/* Reduce the lower triangle of A. II is the index in AP of
A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
d__1 = ap[1].r;
ap[1].r = d__1, ap[1].i = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(i+2:n,i) */
i__2 = ii + 1;
alpha.r = ap[i__2].r, alpha.i = ap[i__2].i;
i__2 = *n - i__;
zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = ii + 1;
ap[i__2].r = 1., ap[i__2].i = 0.;
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
c_b2, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
i__2 = *n - i__;
zdotc_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], &
c__1, &ap[i1i1]);
}
i__2 = ii + 1;
i__3 = i__;
ap[i__2].r = e[i__3], ap[i__2].i = 0.;
i__2 = i__;
i__3 = ii;
d__[i__2] = ap[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r, tau[i__2].i = taui.i;
ii = i1i1;
/* L20: */
}
i__1 = *n;
i__2 = ii;
d__[i__1] = ap[i__2].r;
}
return 0;
/* End of ZHPTRD */
} /* zhptrd_ */
void
zhpr2(char uplo, int n, doublecomplex *alpha, doublecomplex *x, int incx, doublecomplex *y, int incy, doublecomplex *a )
{
zhpr2_( &uplo, &n, alpha, x, &incx, y, &incy, a );
}
/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n,
doublecomplex *ap, doublecomplex *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer j, k, j1, k1, jj, kk;
doublecomplex ct;
doublereal ajj;
integer j1j1;
doublereal akk;
integer k1k1;
doublereal bjj, bkk;
extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *);
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex *
, doublecomplex *, integer *), xerbla_(
char *, integer *), zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPGST reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form, using packed storage. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The triangular factor from the Cholesky factorization of B, */
/* stored in the same format as A, as returned by ZPPTRF. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPGST", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
d__1 = ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
i__2 = jj;
bjj = bp[i__2].r;
ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
ap[j1], &c__1);
i__2 = j - 1;
z__1.r = -1., z__1.i = -0.;
zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
j1], &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
zdscal_(&i__2, &d__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
zdotc_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
z__2.r = ap[i__3].r - z__3.r, z__2.i = ap[i__3].i - z__3.i;
z__1.r = z__2.r / bjj, z__1.i = z__2.i / bjj;
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = kk;
ap[i__2].r = akk, ap[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1]);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1]);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
ap[i__2].r = d__1, ap[i__2].i = 0.;
/* L30: */
}
} else {
/* Compute L'*A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
d__1 = ajj * bjj;
i__3 = *n - j;
zdotc_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = *n - j;
zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b1, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
, &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of ZHPGST */
} /* zhpgst_ */
/* Subroutine */ int zhpt21_(integer *itype, char *uplo, integer *n, integer *
kband, doublecomplex *ap, doublereal *d__, doublereal *e,
doublecomplex *u, integer *ldu, doublecomplex *vp, doublecomplex *tau,
doublecomplex *work, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
static doublereal unfl;
static doublecomplex temp;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *), zhpr2_(char
*, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *);
static integer j;
extern logical lsame_(char *, char *);
static integer iinfo;
static doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static char cuplo[1];
static doublecomplex vsave;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical lower;
static doublereal wnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zhpmv_(char *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), zaxpy_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static integer jp, jr;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *), zlanhp_(char *, char *, integer
*, doublecomplex *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
static integer jp1;
extern /* Subroutine */ int zupmtr_(char *, char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *);
static integer lap;
static doublereal ulp;
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
ZHPT21 generally checks a decomposition of the form
A = U S U*
where * means conjugate transpose, A is hermitian, U is
unitary, and S is diagonal (if KBAND=0) or (real) symmetric
tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as
a dense matrix, otherwise the U is expressed as a product of
Householder transformations, whose vectors are stored in the
array "V" and whose scaling constants are in "TAU"; we shall
use the letter "V" to refer to the product of Householder
transformations (which should be equal to U).
Specifically, if ITYPE=1, then:
RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and*
RESULT(2) = | I - UU* | / ( n ulp )
If ITYPE=2, then:
RESULT(1) = | A - V S V* | / ( |A| n ulp )
If ITYPE=3, then:
RESULT(1) = | I - UV* | / ( n ulp )
Packed storage means that, for example, if UPLO='U', then the columns
of the upper triangle of A are stored one after another, so that
A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if
UPLO='L', then the columns of the lower triangle of A are stored one
after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
in the array AP. This means that A(i,j) is stored in:
AP( i + j*(j-1)/2 ) if UPLO='U'
AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L'
The array VP bears the same relation to the matrix V that A does to
AP.
For ITYPE > 1, the transformation U is expressed as a product
of Householder transformations:
If UPLO='U', then V = H(n-1)...H(1), where
H(j) = I - tau(j) v(j) v(j)*
and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
(i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
the j-th element is 1, and the last n-j elements are 0.
If UPLO='L', then V = H(1)...H(n-1), where
H(j) = I - tau(j) v(j) v(j)*
and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
(j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
Arguments
=========
ITYPE (input) INTEGER
Specifies the type of tests to be performed.
1: U expressed as a dense unitary matrix:
RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and*
RESULT(2) = | I - UU* | / ( n ulp )
2: U expressed as a product V of Housholder transformations:
RESULT(1) = | A - V S V* | / ( |A| n ulp )
3: U expressed both as a dense unitary matrix and
as a product of Housholder transformations:
RESULT(1) = | I - UV* | / ( n ulp )
UPLO (input) CHARACTER
If UPLO='U', the upper triangle of A and V will be used and
the (strictly) lower triangle will not be referenced.
If UPLO='L', the lower triangle of A and V will be used and
the (strictly) upper triangle will not be referenced.
N (input) INTEGER
The size of the matrix. If it is zero, ZHPT21 does nothing.
It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix. It may only be zero or one.
If zero, then S is diagonal, and E is not referenced. If
one, then S is symmetric tri-diagonal.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The original (unfactored) matrix. It is assumed to be
hermitian, and contains the columns of just the upper
triangle (UPLO='U') or only the lower triangle (UPLO='L'),
packed one after another.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix.
E (input) DOUBLE PRECISION array, dimension (N)
The off-diagonal of the (symmetric tri-) diagonal matrix.
E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
(3,2) element, etc.
Not referenced if KBAND=0.
U (input) COMPLEX*16 array, dimension (LDU, N)
If ITYPE=1 or 3, this contains the unitary matrix in
the decomposition, expressed as a dense matrix. If ITYPE=2,
then it is not referenced.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N and
at least 1.
VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
If ITYPE=2 or 3, the columns of this array contain the
Householder vectors used to describe the unitary matrix
in the decomposition, as described in purpose.
*NOTE* If ITYPE=2 or 3, V is modified and restored. The
subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
is set to one, and later reset to its original value, during
the course of the calculation.
If ITYPE=1, then it is neither referenced nor modified.
TAU (input) COMPLEX*16 array, dimension (N)
If ITYPE >= 2, then TAU(j) is the scalar factor of
v(j) v(j)* in the Householder transformation H(j) of
the product U = H(1)...H(n-2)
If ITYPE < 2, then TAU is not referenced.
WORK (workspace) COMPLEX*16 array, dimension (N**2)
Workspace.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
Workspace.
RESULT (output) DOUBLE PRECISION array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
RESULT(1) is always modified. RESULT(2) is modified only
if ITYPE=1.
=====================================================================
Constants
Parameter adjustments */
--ap;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--vp;
--tau;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
if (*itype == 1) {
result[2] = 0.;
}
if (*n <= 0) {
return 0;
}
lap = *n * (*n + 1) / 2;
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10. / ulp;
return 0;
}
/* Do Test 1
Norm of A: */
if (*itype == 3) {
anorm = 1.;
} else {
/* Computing MAX */
d__1 = zlanhp_("1", cuplo, n, &ap[1], &rwork[1])
;
anorm = max(d__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U* */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
zcopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
zhpr_(cuplo, n, &d__1, &u_ref(1, j), &c__1, &work[1]);
/* L10: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__2.r = e[i__2], z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zhpr2_(cuplo, n, &z__1, &u_ref(1, j), &c__1, &u_ref(1, j - 1),
&c__1, &work[1]);
/* L20: */
}
}
wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V* - A */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
if (lower) {
i__1 = lap;
i__2 = *n;
work[i__1].r = d__[i__2], work[i__1].i = 0.;
for (j = *n - 1; j >= 1; --j) {
jp = ((*n << 1) - j) * (j - 1) / 2;
jp1 = jp + *n - j;
if (*kband == 1) {
i__1 = jp + j + 1;
i__2 = j;
z__2.r = 1. - tau[i__2].r, z__2.i = 0. - tau[i__2].i;
i__3 = j;
z__1.r = e[i__3] * z__2.r, z__1.i = e[i__3] * z__2.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
i__2 = jp + jr;
i__3 = j;
z__3.r = -tau[i__3].r, z__3.i = -tau[i__3].i;
i__4 = j;
z__2.r = e[i__4] * z__3.r, z__2.i = e[i__4] * z__3.i;
i__5 = jp + jr;
z__1.r = z__2.r * vp[i__5].r - z__2.i * vp[i__5].i,
z__1.i = z__2.r * vp[i__5].i + z__2.i * vp[
i__5].r;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L30: */
}
}
i__1 = j;
if (tau[i__1].r != 0. || tau[i__1].i != 0.) {
i__1 = jp + j + 1;
vsave.r = vp[i__1].r, vsave.i = vp[i__1].i;
i__1 = jp + j + 1;
vp[i__1].r = 1., vp[i__1].i = 0.;
i__1 = *n - j;
zhpmv_("L", &i__1, &c_b2, &work[jp1 + j + 1], &vp[jp + j
+ 1], &c__1, &c_b1, &work[lap + 1], &c__1);
i__1 = j;
z__2.r = tau[i__1].r * -.5, z__2.i = tau[i__1].i * -.5;
i__2 = *n - j;
zdotc_(&z__3, &i__2, &work[lap + 1], &c__1, &vp[jp + j +
1], &c__1);
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;
temp.r = z__1.r, temp.i = z__1.i;
i__1 = *n - j;
zaxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
1], &c__1);
i__1 = *n - j;
i__2 = j;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zhpr2_("L", &i__1, &z__1, &vp[jp + j + 1], &c__1, &work[
lap + 1], &c__1, &work[jp1 + j + 1]);
i__1 = jp + j + 1;
vp[i__1].r = vsave.r, vp[i__1].i = vsave.i;
}
i__1 = jp + j;
i__2 = j;
work[i__1].r = d__[i__2], work[i__1].i = 0.;
/* L40: */
}
} else {
work[1].r = d__[1], work[1].i = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
jp = j * (j - 1) / 2;
jp1 = jp + j;
if (*kband == 1) {
i__2 = jp1 + j;
i__3 = j;
z__2.r = 1. - tau[i__3].r, z__2.i = 0. - tau[i__3].i;
i__4 = j;
z__1.r = e[i__4] * z__2.r, z__1.i = e[i__4] * z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jp1 + jr;
i__4 = j;
z__3.r = -tau[i__4].r, z__3.i = -tau[i__4].i;
i__5 = j;
z__2.r = e[i__5] * z__3.r, z__2.i = e[i__5] * z__3.i;
i__6 = jp1 + jr;
z__1.r = z__2.r * vp[i__6].r - z__2.i * vp[i__6].i,
z__1.i = z__2.r * vp[i__6].i + z__2.i * vp[
i__6].r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L50: */
}
}
i__2 = j;
if (tau[i__2].r != 0. || tau[i__2].i != 0.) {
i__2 = jp1 + j;
vsave.r = vp[i__2].r, vsave.i = vp[i__2].i;
i__2 = jp1 + j;
vp[i__2].r = 1., vp[i__2].i = 0.;
zhpmv_("U", &j, &c_b2, &work[1], &vp[jp1 + 1], &c__1, &
c_b1, &work[lap + 1], &c__1);
i__2 = j;
z__2.r = tau[i__2].r * -.5, z__2.i = tau[i__2].i * -.5;
zdotc_(&z__3, &j, &work[lap + 1], &c__1, &vp[jp1 + 1], &
c__1);
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;
temp.r = z__1.r, temp.i = z__1.i;
zaxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
c__1);
i__2 = j;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zhpr2_("U", &j, &z__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
, &c__1, &work[1]);
i__2 = jp1 + j;
vp[i__2].r = vsave.r, vp[i__2].i = vsave.i;
}
i__2 = jp1 + j + 1;
i__3 = j + 1;
work[i__2].r = d__[i__3], work[i__2].i = 0.;
/* L60: */
}
}
i__1 = lap;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
i__3 = j;
i__4 = j;
z__1.r = work[i__3].r - ap[i__4].r, z__1.i = work[i__3].i - ap[
i__4].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L70: */
}
wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V* - I */
if (*n < 2) {
return 0;
}
zlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
/* Computing 2nd power */
i__1 = *n;
zupmtr_("R", cuplo, "C", n, n, &vp[1], &tau[1], &work[1], n, &work[
i__1 * i__1 + 1], &iinfo);
if (iinfo != 0) {
result[1] = 10. / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 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;
/* L80: */
}
wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[1] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[1] = min(d__1,d__2) / (*n * ulp);
}
}
/* Do Test 2
Compute UU* - I */
if (*itype == 1) {
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 (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 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;
/* L90: */
}
/* Computing MIN */
d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
doublereal) (*n);
result[2] = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of ZHPT21 */
} /* zhpt21_ */
/* Subroutine */
int zhpgst_(integer *itype, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer j, k, j1, k1, jj, kk;
doublecomplex ct;
doublereal ajj;
integer j1j1;
doublereal akk;
integer k1k1;
doublereal bjj, bkk;
extern /* Subroutine */
int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *);
extern logical lsame_(char *, char *);
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */
int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * , doublecomplex *, integer *), xerbla_( char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3)
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHPGST", &i__1);
return 0;
}
if (*itype == 1)
{
if (upper)
{
/* Compute inv(U**H)*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
d__1 = ap[i__3].r;
ap[i__2].r = d__1;
ap[i__2].i = 0.; // , expr subst
i__2 = jj;
bjj = bp[i__2].r;
ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1);
i__2 = j - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
zdscal_(&i__2, &d__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
zdotc_f2c_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
z__2.r = ap[i__3].r - z__3.r;
z__2.i = ap[i__3].i - z__3.i; // , expr subst
z__1.r = z__2.r / bjj;
z__1.i = z__2.i / bjj; // , expr subst
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
/* L10: */
}
}
else
{
/* Compute inv(L)*A*inv(L**H) */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = kk;
ap[i__2].r = akk;
ap[i__2].i = 0.; // , expr subst
if (k < *n)
{
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
d__1 = akk * -.5;
ct.r = d__1;
ct.i = 0.; // , expr subst
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
}
else
{
if (upper)
{
/* Compute U*A*U**H */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1);
d__1 = akk * .5;
ct.r = d__1;
ct.i = 0.; // , expr subst
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
ap[i__2].r = d__1;
ap[i__2].i = 0.; // , expr subst
/* L30: */
}
}
else
{
/* Compute L**H *A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
d__1 = ajj * bjj;
i__3 = *n - j;
zdotc_f2c_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
z__1.r = d__1 + z__2.r;
z__1.i = z__2.i; // , expr subst
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
i__2 = *n - j;
zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of ZHPGST */
}