int
f2c_chpmv(char* uplo, integer* N,
complex* alpha,
complex* Ap,
complex* X, integer* incX,
complex* beta,
complex* Y, integer* incY)
{
chpmv_(uplo, N, alpha, Ap,
X, incX, beta, Y, incY);
return 0;
}
/* Subroutine */ int chprfs_(char *uplo, integer *n, integer *nrhs, complex *
ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,
integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k;
real s;
integer ik, kk;
real xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), chpmv_(char *, integer *, complex *,
complex *, complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *,
complex *, integer *);
integer count;
logical upper;
extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
*, integer *, integer *);
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), chptrs_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *, integer *);
real lstres;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is Hermitian indefinite */
/* and packed, and provides error bounds and backward error estimates */
/* for the solution. */
/* 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. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* 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. */
/* AFP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The factored form of the matrix A. AFP contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor U or L from the factorization A = U*D*U**H or */
/* A = L*D*L**H as computed by CHPTRF, stored as a packed */
/* triangular matrix. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CHPTRF. */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by CHPTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--afp;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
q__1.r = -1.f, q__1.i = -0.f;
chpmv_(uplo, n, &q__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &
work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
i__ + j * b_dim1]), dabs(r__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
kk = 1;
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
* x_dim1]), dabs(r__2));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ik;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[ik]), dabs(r__2))) * xk;
i__4 = ik;
i__5 = i__ + j * x_dim1;
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
dabs(r__4)));
++ik;
/* L40: */
}
i__3 = kk + k - 1;
rwork[k] = rwork[k] + (r__1 = ap[i__3].r, dabs(r__1)) * xk +
s;
kk += k;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
* x_dim1]), dabs(r__2));
i__3 = kk;
rwork[k] += (r__1 = ap[i__3].r, dabs(r__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = ik;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[ik]), dabs(r__2))) * xk;
i__4 = ik;
i__5 = i__ + j * x_dim1;
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
dabs(r__4)));
++ik;
/* L60: */
}
rwork[k] += s;
kk += *n - k + 1;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__4);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
/* Use CLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L120: */
}
chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L130: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of CHPRFS */
} /* chprfs_ */
void
chpmv(char uplo, int n, complex *alpha, complex *ap, complex *x, int incx, complex *beta, complex *y, int incy)
{
chpmv_( &uplo, &n, alpha, ap, x, &incx, beta, y, &incy );
}
/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex *
ap, complex *bp, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
static integer j, k, j1, k1, jj, kk;
static complex ct;
static real ajj;
static integer j1j1;
static real akk;
static integer k1k1;
static real bjj, bkk;
extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, ftnlen);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
, complex *, integer *, complex *, complex *, integer *, ftnlen),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), ctpmv_(char *, char *, char *, integer *, complex *,
complex *, integer *, ftnlen, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen, ftnlen), csscal_(
integer *, real *, complex *, integer *), xerbla_(char *, integer
*, ftnlen);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPGST 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 CPPTRF. */
/* 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 */
/* = '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 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 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 CPPTRF. */
/* 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", (ftnlen)1, (ftnlen)1);
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPGST", &i__1, (ftnlen)6);
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;
r__1 = ap[i__3].r;
ap[i__2].r = r__1, ap[i__2].i = 0.f;
i__2 = jj;
bjj = bp[i__2].r;
ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
ap[j1], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
i__2 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
j1], &c__1, (ftnlen)1);
i__2 = j - 1;
r__1 = 1.f / bjj;
csscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
cdotc_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
q__2.r = ap[i__3].r - q__3.r, q__2.i = ap[i__3].i - q__3.i;
q__1.r = q__2.r / bjj, q__1.i = q__2.i / bjj;
ap[i__2].r = q__1.r, ap[i__2].i = q__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 */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = kk;
ap[i__2].r = akk, ap[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1], (ftnlen)1);
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1, (ftnlen)1, (ftnlen)12, (
ftnlen)8);
}
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;
ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1], (ftnlen)1);
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
ap[i__2].r = r__1, ap[i__2].i = 0.f;
/* 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;
r__1 = ajj * bjj;
i__3 = *n - j;
cdotc_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
q__1.r = r__1 + q__2.r, q__1.i = q__2.i;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = *n - j;
csscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b1, &ap[jj + 1], &c__1, (ftnlen)1);
i__2 = *n - j + 1;
ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
, &ap[jj], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of CHPGST */
} /* chpgst_ */
/* Subroutine */ int cppt03_(char *uplo, integer *n, complex *a, complex *
ainv, complex *work, integer *ldwork, real *rwork, real *rcond, real *
resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, jj;
real eps;
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), chpmv_(char *, integer *, complex *,
complex *, complex *, integer *, complex *, complex *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhp_(char *, char *, integer *,
complex *, real *), slamch_(char *);
real ainvnm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPT03 computes the residual for a Hermitian packed matrix times its */
/* inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* 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 number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AINV (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The (Hermitian) inverse of the matrix A, stored as a packed */
/* triangular matrix. */
/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of A, computed as */
/* ( 1/norm(A) ) / norm(AINV). */
/* RESID (output) REAL */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--a;
--ainv;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*rcond = 1.f;
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = slamch_("Epsilon");
anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
ainvnm = clanhp_("1", uplo, n, &ainv[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / anorm / ainvnm;
/* UPLO = 'U': */
/* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */
/* expand it to a full matrix, then multiply by A one column at a */
/* time, moving the result one column to the left. */
if (lsame_(uplo, "U")) {
/* Copy AINV */
jj = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ccopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
c__1);
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + (i__ + 1) * work_dim1;
r_cnjg(&q__1, &ainv[jj + i__ - 1]);
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L10: */
}
jj += j;
/* L20: */
}
jj = (*n - 1) * *n / 2 + 1;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n + (i__ + 1) * work_dim1;
r_cnjg(&q__1, &ainv[jj + i__ - 1]);
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L30: */
}
/* Multiply by A */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Upper", n, &q__1, &a[1], &work[(j + 1) * work_dim1 + 1], &
c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
/* L40: */
}
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Upper", n, &q__1, &a[1], &ainv[jj], &c__1, &c_b1, &work[*n *
work_dim1 + 1], &c__1);
/* UPLO = 'L': */
/* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */
/* and multiply by A, moving each column to the right. */
} else {
/* Copy AINV */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ * work_dim1 + 1;
r_cnjg(&q__1, &ainv[i__ + 1]);
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
jj = *n + 1;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = *n - j + 1;
ccopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
c__1);
i__2 = *n - j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + (j + i__ - 1) * work_dim1;
r_cnjg(&q__1, &ainv[jj + i__]);
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L60: */
}
jj = jj + *n - j + 1;
/* L70: */
}
/* Multiply by A */
for (j = *n; j >= 2; --j) {
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Lower", n, &q__1, &a[1], &work[(j - 1) * work_dim1 + 1], &
c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
/* L80: */
}
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Lower", n, &q__1, &a[1], &ainv[1], &c__1, &c_b1, &work[
work_dim1 + 1], &c__1);
}
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * work_dim1;
i__3 = i__ + i__ * work_dim1;
q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i + 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L90: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = clange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (real) (*n);
return 0;
/* End of CPPT03 */
} /* cppt03_ */
/* Subroutine */ int cppt02_(char *uplo, integer *n, integer *nrhs, complex *
a, complex *x, integer *ldx, complex *b, integer *ldb, real *rwork,
real *resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
complex q__1;
/* Local variables */
integer j;
real eps, anorm, bnorm;
real xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPT02 computes the residual in the solution of a Hermitian system */
/* of linear equations A*x = b when packed storage is used for the */
/* coefficient matrix. The ratio computed is */
/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */
/* where EPS is the machine precision. */
/* 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 number of rows and columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B, the matrix of right hand sides. */
/* NRHS >= 0. */
/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
--a;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - A*X for the matrix of right hand sides B. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
q__1.r = -1.f, q__1.i = -0.f;
chpmv_(uplo, n, &q__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j *
b_dim1 + 1], &c__1);
/* L10: */
}
/* Compute the maximum over the number of right hand sides of */
/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L20: */
}
return 0;
/* End of CPPT02 */
} /* cppt02_ */
/* Subroutine */ int chptrd_(char *uplo, integer *n, complex *ap, real *d__,
real *e, complex *tau, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
integer i__, i1, ii, i1i1;
complex taui;
extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *);
complex alpha;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
, complex *, integer *, complex *, complex *, integer *),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *);
logical upper;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPTRD 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 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) REAL array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) REAL 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 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). */
/* ===================================================================== */
/* .. 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_("CHPTRD", &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;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
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;
clarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f) {
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i1 + i__ - 1;
ap[i__1].r = 1.f, ap[i__1].i = 0.f;
/* Compute y := tau * A * v storing y in TAU(1:i) */
chpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[
1], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
taui.i + q__3.i * taui.r;
cdotc_(&q__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
caxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__, &q__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.f;
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;
r__1 = ap[1].r;
ap[1].r = r__1, ap[1].i = 0.f;
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__;
clarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = ii + 1;
ap[i__2].r = 1.f, ap[i__2].i = 0.f;
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
chpmv_(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 */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
taui.i + q__3.i * taui.r;
i__2 = *n - i__;
cdotc_(&q__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - i__;
caxpy_(&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__;
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__2, &q__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.f;
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 CHPTRD */
} /* chptrd_ */
/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
complex *a, integer *lda, complex *x, integer *ldx, complex *b,
integer *ldb, integer *iseed, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
integer j;
char c1[1], c2[2];
integer mb, nx;
logical gen, tri, qrs, sym, band;
char diag[1];
logical tran;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), chemm_(char *,
char *, integer *, integer *, complex *, complex *, integer *,
complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *), chbmv_(char *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ctbmv_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *,
complex *, integer *, complex *, complex *, integer *),
ctrmm_(char *, char *, char *, char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *,
complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ctpmv_(char *, char *, char *,
integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
*, complex *, integer *), xerbla_(char *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *);
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARHS chooses a set of NRHS random solution vectors and sets */
/* up the right hand sides for the linear system */
/* op( A ) * X = B, */
/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
/* transpose of A). */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The type of the complex matrix A. PATH may be given in any */
/* combination of upper and lower case. Valid paths include */
/* xGE: General m x n matrix */
/* xGB: General banded matrix */
/* xPO: Hermitian positive definite, 2-D storage */
/* xPP: Hermitian positive definite packed */
/* xPB: Hermitian positive definite banded */
/* xHE: Hermitian indefinite, 2-D storage */
/* xHP: Hermitian indefinite packed */
/* xHB: Hermitian indefinite banded */
/* xSY: Symmetric indefinite, 2-D storage */
/* xSP: Symmetric indefinite packed */
/* xSB: Symmetric indefinite banded */
/* xTR: Triangular */
/* xTP: Triangular packed */
/* xTB: Triangular banded */
/* xQR: General m x n matrix */
/* xLQ: General m x n matrix */
/* xQL: General m x n matrix */
/* xRQ: General m x n matrix */
/* where the leading character indicates the precision. */
/* XTYPE (input) CHARACTER*1 */
/* Specifies how the exact solution X will be determined: */
/* = 'N': New solution; generate a random X. */
/* = 'C': Computed; use value of X on entry. */
/* UPLO (input) CHARACTER*1 */
/* Used only if A is symmetric or triangular; specifies whether */
/* the upper or lower triangular part of the matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Used only if A is nonsymmetric; specifies the operation */
/* applied to the matrix A. */
/* = 'N': B := A * X */
/* = 'T': B := A**T * X */
/* = 'C': B := A**H * X */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* Used only if A is a band matrix; specifies the number of */
/* subdiagonals of A if A is a general band matrix or if A is */
/* symmetric or triangular and UPLO = 'L'; specifies the number */
/* of superdiagonals of A if A is symmetric or triangular and */
/* UPLO = 'U'. 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* Used only if A is a general band matrix or if A is */
/* triangular. */
/* If PATH = xGB, specifies the number of superdiagonals of A, */
/* and 0 <= KU <= N-1. */
/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
/* matrix has unit diagonal: */
/* = 1: matrix has non-unit diagonal (default) */
/* = 2: matrix has unit diagonal */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors in the system A*X = B. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The test matrix whose type is given by PATH. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If PATH = xGB, LDA >= KL+KU+1. */
/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
/* Otherwise, LDA >= max(1,M). */
/* X (input or output) COMPLEX array, dimension (LDX,NRHS) */
/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
/* the exact solution to the system of linear equations. */
/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
/* with random values. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
/* B (output) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side vector(s) for the system of equations, */
/* computed from B = op(A) * X, where op(A) is determined by */
/* TRANS. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. If TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* CLATMS). Modified on exit. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--iseed;
/* Function Body */
*info = 0;
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
tran = lsame_(trans, "T") || lsame_(trans, "C");
notran = ! tran;
gen = lsame_(path + 1, "G");
qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
"Q");
sym = lsame_(path + 1, "P") || lsame_(path + 1,
"S") || lsame_(path + 1, "H");
tri = lsame_(path + 1, "T");
band = lsame_(path + 2, "B");
if (! lsame_(c1, "Complex precision")) {
*info = -1;
} else if (! (lsame_(xtype, "N") || lsame_(xtype,
"C"))) {
*info = -2;
} else if ((sym || tri) && ! (lsame_(uplo, "U") ||
lsame_(uplo, "L"))) {
*info = -3;
} else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
*info = -4;
} else if (*m < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (band && *kl < 0) {
*info = -7;
} else if (band && *ku < 0) {
*info = -8;
} else if (*nrhs < 0) {
*info = -9;
} else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
kl + 1 || band && gen && *lda < *kl + *ku + 1) {
*info = -11;
} else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
*info = -13;
} else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLARHS", &i__1);
return 0;
}
/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
if (tran) {
nx = *m;
mb = *n;
} else {
nx = *n;
mb = *m;
}
if (! lsame_(xtype, "C")) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
clarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
/* L10: */
}
}
/* Multiply X by op( A ) using an appropriate */
/* matrix multiply routine. */
if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
"QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
lsamen_(&c__2, c2, "RQ")) {
/* General matrix */
cgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
x_offset], ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
c__2, c2, "HE")) {
/* Hermitian matrix, 2-D storage */
chemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "SY")) {
/* Symmetric matrix, 2-D storage */
csymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
cgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L20: */
}
} else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
c__2, c2, "HB")) {
/* Hermitian matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
chbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L30: */
}
} else if (lsamen_(&c__2, c2, "SB")) {
/* Symmetric matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
csbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L40: */
}
} else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
c__2, c2, "HP")) {
/* Hermitian matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
chpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L50: */
}
} else if (lsamen_(&c__2, c2, "SP")) {
/* Symmetric matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
cspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L60: */
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrix. Note that for triangular matrices, */
/* KU = 1 => non-unit triangular */
/* KU = 2 => unit triangular */
clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
ctrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular matrix, packed storage */
clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ctpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
c__1);
/* L70: */
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular matrix, banded storage */
clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ctbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ 1], &c__1);
/* L80: */
}
} else {
/* If none of the above, set INFO = -1 and return */
*info = -1;
i__1 = -(*info);
xerbla_("CLARHS", &i__1);
}
return 0;
/* End of CLARHS */
} /* clarhs_ */
void cblas_chpmv(const enum CBLAS_ORDER order,
const enum CBLAS_UPLO Uplo,const integer N,
const void *alpha, const void *AP,
const void *X, const integer incX, const void *beta,
void *Y, const integer incY)
{
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=0, incx=incX;
const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta;
float ALPHA[2],BETA[2];
integer tincY, tincx;
float *x=(float *)X, *y=(float *)Y, *st=0, *tx;
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_chpmv","Illegal Uplo setting, %d\n",Uplo );
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
chpmv_(F77_UL, &F77_N, alpha, AP, X,
&F77_incX, beta, Y, &F77_incY);
}
else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
ALPHA[0]= *alp;
ALPHA[1]= -alp[1];
BETA[0]= *bet;
BETA[1]= -bet[1];
if (N > 0)
{
n = N << 1;
x = malloc(n*sizeof(float));
tx = x;
if( incX > 0 ) {
i = incX << 1;
tincx = 2;
st= x+n;
} else {
i = incX *(-2);
tincx = -2;
st = x-2;
x +=(n-2);
}
do
{
*x = *xx;
x[1] = -xx[1];
x += tincx ;
xx += i;
}
while (x != st);
x=tx;
incx = 1;
if(incY > 0)
tincY = incY;
else
tincY = -incY;
y++;
i = tincY << 1;
n = i * N ;
st = y + n;
do {
*y = -(*y);
y += i;
} while(y != st);
y -= n;
} else
x = (float *) X;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n", Uplo );
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
chpmv_(F77_UL, &F77_N, ALPHA,
AP, x, &F77_incX, BETA, Y, &F77_incY);
}
else
{
cblas_xerbla(1, "cblas_chpmv","Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if ( order == CblasRowMajor )
{
RowMajorStrg = 1;
if(X!=x)
free(x);
if (N > 0)
{
do
{
*y = -(*y);
y += i;
}
while (y != st);
}
}
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
/* Subroutine */ int chptri_(char *uplo, integer *n, complex *ap, integer *
ipiv, complex *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHPTRI computes the inverse of a complex Hermitian indefinite matrix
A in packed storage using the factorization A = U*D*U**H or
A = L*D*L**H computed by CHPTRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**H;
= 'L': Lower triangular, form is A = L*D*L**H.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the block diagonal matrix D and the multipliers
used to obtain the factor U or L as computed by CHPTRF,
stored as a packed triangular matrix.
On exit, if INFO = 0, the (Hermitian) inverse of the original
matrix, stored as a packed triangular matrix. The j-th column
of inv(A) is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
if UPLO = 'L',
AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CHPTRF.
WORK (workspace) COMPLEX array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b2 = {0.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
complex q__1, q__2;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static complex temp, akkp1;
static real d;
static integer j, k;
static real t;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), chpmv_(char *, integer *, complex *,
complex *, complex *, integer *, complex *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *,
integer *);
static integer kstep;
static logical upper;
static real ak;
static integer kc, kp, kx;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer kcnext, kpc, npp;
static real akp1;
#define WORK(I) work[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define AP(I) ap[(I)-1]
*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_("CHPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
kp = *n * (*n + 1) / 2;
for (*info = *n; *info >= 1; --(*info)) {
i__1 = kp;
if (IPIV(*info) > 0 && (AP(kp).r == 0.f && AP(kp).i == 0.f)) {
return 0;
}
kp -= *info;
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
kp = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = kp;
if (IPIV(*info) > 0 && (AP(kp).r == 0.f && AP(kp).i == 0.f)) {
return 0;
}
kp = kp + *n - *info + 1;
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
kcnext = kc + k;
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = 1.f / AP(kc+k-1).r;
AP(kc+k-1).r = d__1, AP(kc+k-1).i = 0.f;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &AP(kc), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
chpmv_(uplo, &i__1, &q__1, &AP(1), &WORK(1), &c__1, &c_b2, &
AP(kc), &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc), &c__1);
d__1 = q__2.r;
q__1.r = AP(kc+k-1).r - d__1, q__1.i = AP(kc+k-1).i;
AP(kc+k-1).r = q__1.r, AP(kc+k-1).i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = c_abs(&AP(kcnext + k - 1));
i__1 = kc + k - 1;
ak = AP(kc+k-1).r / t;
i__1 = kcnext + k;
akp1 = AP(kcnext+k).r / t;
i__1 = kcnext + k - 1;
q__1.r = AP(kcnext+k-1).r / t, q__1.i = AP(kcnext+k-1).i / t;
akkp1.r = q__1.r, akkp1.i = q__1.i;
d = t * (ak * akp1 - 1.f);
i__1 = kc + k - 1;
d__1 = akp1 / d;
AP(kc+k-1).r = d__1, AP(kc+k-1).i = 0.f;
i__1 = kcnext + k;
d__1 = ak / d;
AP(kcnext+k).r = d__1, AP(kcnext+k).i = 0.f;
i__1 = kcnext + k - 1;
q__2.r = -(doublereal)akkp1.r, q__2.i = -(doublereal)akkp1.i;
q__1.r = q__2.r / d, q__1.i = q__2.i / d;
AP(kcnext+k-1).r = q__1.r, AP(kcnext+k-1).i = q__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &AP(kc), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
chpmv_(uplo, &i__1, &q__1, &AP(1), &WORK(1), &c__1, &c_b2, &
AP(kc), &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc), &c__1);
d__1 = q__2.r;
q__1.r = AP(kc+k-1).r - d__1, q__1.i = AP(kc+k-1).i;
AP(kc+k-1).r = q__1.r, AP(kc+k-1).i = q__1.i;
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &AP(kc), &c__1, &AP(kcnext), &c__1);
q__1.r = AP(kcnext+k-1).r - q__2.r, q__1.i = AP(kcnext+k-1).i - q__2.i;
AP(kcnext+k-1).r = q__1.r, AP(kcnext+k-1).i = q__1.i;
i__1 = k - 1;
ccopy_(&i__1, &AP(kcnext), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
chpmv_(uplo, &i__1, &q__1, &AP(1), &WORK(1), &c__1, &c_b2, &
AP(kcnext), &c__1);
i__1 = kcnext + k;
i__2 = kcnext + k;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kcnext), &c__1);
d__1 = q__2.r;
q__1.r = AP(kcnext+k).r - d__1, q__1.i = AP(kcnext+k).i;
AP(kcnext+k).r = q__1.r, AP(kcnext+k).i = q__1.i;
}
kstep = 2;
kcnext = kcnext + k + 1;
}
kp = (i__1 = IPIV(k), abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading
submatrix A(1:k+1,1:k+1) */
kpc = (kp - 1) * kp / 2 + 1;
i__1 = kp - 1;
cswap_(&i__1, &AP(kc), &c__1, &AP(kpc), &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= k-1; ++j) {
kx = kx + j - 1;
r_cnjg(&q__1, &AP(kc + j - 1));
temp.r = q__1.r, temp.i = q__1.i;
i__2 = kc + j - 1;
r_cnjg(&q__1, &AP(kx));
AP(kc+j-1).r = q__1.r, AP(kc+j-1).i = q__1.i;
i__2 = kx;
AP(kx).r = temp.r, AP(kx).i = temp.i;
/* L40: */
}
i__1 = kc + kp - 1;
r_cnjg(&q__1, &AP(kc + kp - 1));
AP(kc+kp-1).r = q__1.r, AP(kc+kp-1).i = q__1.i;
i__1 = kc + k - 1;
temp.r = AP(kc+k-1).r, temp.i = AP(kc+k-1).i;
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
AP(kc+k-1).r = AP(kpc+kp-1).r, AP(kc+k-1).i = AP(kpc+kp-1).i;
i__1 = kpc + kp - 1;
AP(kpc+kp-1).r = temp.r, AP(kpc+kp-1).i = temp.i;
if (kstep == 2) {
i__1 = kc + k + k - 1;
temp.r = AP(kc+k+k-1).r, temp.i = AP(kc+k+k-1).i;
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
AP(kc+k+k-1).r = AP(kc+k+kp-1).r, AP(kc+k+k-1).i = AP(kc+k+kp-1).i;
i__1 = kc + k + kp - 1;
AP(kc+k+kp-1).r = temp.r, AP(kc+k+kp-1).i = temp.i;
}
}
k += kstep;
kc = kcnext;
goto L30;
L50:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
npp = *n * (*n + 1) / 2;
k = *n;
kc = npp;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
kcnext = kc - (*n - k + 2);
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = kc;
i__2 = kc;
d__1 = 1.f / AP(kc).r;
AP(kc).r = d__1, AP(kc).i = 0.f;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
chpmv_(uplo, &i__1, &q__1, &AP(kc + *n - k + 1), &WORK(1), &
c__1, &c_b2, &AP(kc + 1), &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc + 1), &c__1);
d__1 = q__2.r;
q__1.r = AP(kc).r - d__1, q__1.i = AP(kc).i;
AP(kc).r = q__1.r, AP(kc).i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = c_abs(&AP(kcnext + 1));
i__1 = kcnext;
ak = AP(kcnext).r / t;
i__1 = kc;
akp1 = AP(kc).r / t;
i__1 = kcnext + 1;
q__1.r = AP(kcnext+1).r / t, q__1.i = AP(kcnext+1).i / t;
akkp1.r = q__1.r, akkp1.i = q__1.i;
d = t * (ak * akp1 - 1.f);
i__1 = kcnext;
d__1 = akp1 / d;
AP(kcnext).r = d__1, AP(kcnext).i = 0.f;
i__1 = kc;
d__1 = ak / d;
AP(kc).r = d__1, AP(kc).i = 0.f;
i__1 = kcnext + 1;
q__2.r = -(doublereal)akkp1.r, q__2.i = -(doublereal)akkp1.i;
q__1.r = q__2.r / d, q__1.i = q__2.i / d;
AP(kcnext+1).r = q__1.r, AP(kcnext+1).i = q__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
chpmv_(uplo, &i__1, &q__1, &AP(kc + (*n - k + 1)), &WORK(1), &
c__1, &c_b2, &AP(kc + 1), &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc + 1), &c__1);
d__1 = q__2.r;
q__1.r = AP(kc).r - d__1, q__1.i = AP(kc).i;
AP(kc).r = q__1.r, AP(kc).i = q__1.i;
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &AP(kc + 1), &c__1, &AP(kcnext + 2), &
c__1);
q__1.r = AP(kcnext+1).r - q__2.r, q__1.i = AP(kcnext+1).i - q__2.i;
AP(kcnext+1).r = q__1.r, AP(kcnext+1).i = q__1.i;
i__1 = *n - k;
ccopy_(&i__1, &AP(kcnext + 2), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
chpmv_(uplo, &i__1, &q__1, &AP(kc + (*n - k + 1)), &WORK(1), &
c__1, &c_b2, &AP(kcnext + 2), &c__1);
i__1 = kcnext;
i__2 = kcnext;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kcnext + 2), &c__1);
d__1 = q__2.r;
q__1.r = AP(kcnext).r - d__1, q__1.i = AP(kcnext).i;
AP(kcnext).r = q__1.r, AP(kcnext).i = q__1.i;
}
kstep = 2;
kcnext -= *n - k + 3;
}
kp = (i__1 = IPIV(k), abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing
submatrix A(k-1:n,k-1:n) */
kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
if (kp < *n) {
i__1 = *n - kp;
cswap_(&i__1, &AP(kc + kp - k + 1), &c__1, &AP(kpc + 1), &
c__1);
}
kx = kc + kp - k;
i__1 = kp - 1;
for (j = k + 1; j <= kp-1; ++j) {
kx = kx + *n - j + 1;
r_cnjg(&q__1, &AP(kc + j - k));
temp.r = q__1.r, temp.i = q__1.i;
i__2 = kc + j - k;
r_cnjg(&q__1, &AP(kx));
AP(kc+j-k).r = q__1.r, AP(kc+j-k).i = q__1.i;
i__2 = kx;
AP(kx).r = temp.r, AP(kx).i = temp.i;
/* L70: */
}
i__1 = kc + kp - k;
r_cnjg(&q__1, &AP(kc + kp - k));
AP(kc+kp-k).r = q__1.r, AP(kc+kp-k).i = q__1.i;
i__1 = kc;
temp.r = AP(kc).r, temp.i = AP(kc).i;
i__1 = kc;
i__2 = kpc;
AP(kc).r = AP(kpc).r, AP(kc).i = AP(kpc).i;
i__1 = kpc;
AP(kpc).r = temp.r, AP(kpc).i = temp.i;
if (kstep == 2) {
i__1 = kc - *n + k - 1;
temp.r = AP(kc-*n+k-1).r, temp.i = AP(kc-*n+k-1).i;
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
AP(kc-*n+k-1).r = AP(kc-*n+kp-1).r, AP(kc-*n+k-1).i = AP(kc-*n+kp-1).i;
i__1 = kc - *n + kp - 1;
AP(kc-*n+kp-1).r = temp.r, AP(kc-*n+kp-1).i = temp.i;
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of CHPTRI */
} /* chptri_ */
/* Subroutine */
int chpgst_(integer *itype, char *uplo, integer *n, complex * ap, complex *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
integer j, k, j1, k1, jj, kk;
complex ct;
real ajj;
integer j1j1;
real akk;
integer k1k1;
real bjj, bkk;
extern /* Subroutine */
int chpr2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *);
extern /* Complex */
VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int chpmv_(char *, integer *, complex *, complex * , complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), csscal_( integer *, real *, complex *, integer *), xerbla_(char *, 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_("CHPGST", &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;
r__1 = ap[i__3].r;
ap[i__2].r = r__1;
ap[i__2].i = 0.f; // , expr subst
i__2 = jj;
bjj = bp[i__2].r;
ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1);
i__2 = j - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1);
i__2 = j - 1;
r__1 = 1.f / bjj;
csscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
cdotc_f2c_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
q__2.r = ap[i__3].r - q__3.r;
q__2.i = ap[i__3].i - q__3.i; // , expr subst
q__1.r = q__2.r / bjj;
q__1.i = q__2.i / bjj; // , expr subst
ap[i__2].r = q__1.r;
ap[i__2].i = q__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 */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = kk;
ap[i__2].r = akk;
ap[i__2].i = 0.f; // , expr subst
if (k < *n)
{
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1;
ct.i = 0.f; // , expr subst
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]);
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
ctpsv_(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;
ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1);
r__1 = akk * .5f;
ct.r = r__1;
ct.i = 0.f; // , expr subst
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]);
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
ap[i__2].r = r__1;
ap[i__2].i = 0.f; // , 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;
r__1 = ajj * bjj;
i__3 = *n - j;
cdotc_f2c_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
q__1.r = r__1 + q__2.r;
q__1.i = q__2.i; // , expr subst
ap[i__2].r = q__1.r;
ap[i__2].i = q__1.i; // , expr subst
i__2 = *n - j;
csscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of CHPGST */
}
