/* Subroutine */ int zsptri_(char *uplo, integer *n, doublecomplex *ap,
integer *ipiv, doublecomplex *work, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublecomplex z__1, z__2, z__3;
/* Local variables */
doublecomplex d__;
integer j, k;
doublecomplex t, ak;
integer kc, kp, kx, kpc, npp;
doublecomplex akp1, temp, akkp1;
integer kstep;
logical upper;
integer kcnext;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZSPTRI computes the inverse of a complex symmetric indefinite matrix */
/* A in packed storage using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by ZSPTRF. */
/* 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**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* 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 block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by ZSPTRF, */
/* stored as a packed triangular matrix. */
/* On exit, if INFO = 0, the (symmetric) 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 ZSPTRF. */
/* WORK (workspace) COMPLEX*16 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 */
--work;
--ipiv;
--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_("ZSPTRI", &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[i__1].r == 0. && ap[i__1].i == 0.)) {
return 0;
}
kp -= *info;
}
} 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[i__2].r == 0. && ap[i__2].i == 0.)) {
return 0;
}
kp = kp + *n - *info + 1;
}
}
*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;
z_div(&z__1, &c_b1, &ap[kc + k - 1]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__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;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + k - 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
z_div(&z__1, &ap[kc + k - 1], &t);
ak.r = z__1.r, ak.i = z__1.i;
z_div(&z__1, &ap[kcnext + k], &t);
akp1.r = z__1.r, akp1.i = z__1.i;
z_div(&z__1, &ap[kcnext + k - 1], &t);
akkp1.r = z__1.r, akkp1.i = z__1.i;
z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
ak.i * akp1.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
* z__2.r;
d__.r = z__1.r, d__.i = z__1.i;
i__1 = kc + k - 1;
z_div(&z__1, &akp1, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + k;
z_div(&z__1, &ak, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + k - 1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z_div(&z__1, &z__2, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__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;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
zdotu_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = k - 1;
zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__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;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__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;
zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
i__2 = kc + j - 1;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - 1;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
}
i__1 = kc + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc + k + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + k + kp - 1;
ap[i__1].r = temp.r, ap[i__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;
z_div(&z__1, &c_b1, &ap[kc]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__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;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
z_div(&z__1, &ap[kcnext], &t);
ak.r = z__1.r, ak.i = z__1.i;
z_div(&z__1, &ap[kc], &t);
akp1.r = z__1.r, akp1.i = z__1.i;
z_div(&z__1, &ap[kcnext + 1], &t);
akkp1.r = z__1.r, akkp1.i = z__1.i;
z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
ak.i * akp1.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
* z__2.r;
d__.r = z__1.r, d__.i = z__1.i;
i__1 = kcnext;
z_div(&z__1, &akp1, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kc;
z_div(&z__1, &ak, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + 1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z_div(&z__1, &z__2, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__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;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
zdotu_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = *n - k;
zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__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;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__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;
zswap_(&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 <= i__1; ++j) {
kx = kx + *n - j + 1;
i__2 = kc + j - k;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - k;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
}
i__1 = kc;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc - *n + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc - *n + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of ZSPTRI */
} /* zsptri_ */
/* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
doublecomplex *b, integer *ldb, integer *iseed, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
integer j;
char c1[1], c2[2];
integer mb, nx;
logical gen, tri, qrs, sym, band;
char diag[1];
logical tran;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhemm_(char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgbmv_(char *, integer *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhbmv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zsbmv_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), ztbmv_(char
*, char *, char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zhpmv_(
char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zspmv_(char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zsymm_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *
, doublecomplex *, integer *), xerbla_(
char *, integer *);
extern logical lsamen_(integer *, char *, char *);
logical notran;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlarnv_(integer *, integer *, integer *, doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARHS chooses a set of NRHS random solution vectors and sets */
/* up the right hand sides for the linear system */
/* op( A ) * X = B, */
/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
/* transpose of A). */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The type of the complex matrix A. PATH may be given in any */
/* combination of upper and lower case. Valid paths include */
/* xGE: General m x n matrix */
/* xGB: General banded matrix */
/* xPO: Hermitian positive definite, 2-D storage */
/* xPP: Hermitian positive definite packed */
/* xPB: Hermitian positive definite banded */
/* xHE: Hermitian indefinite, 2-D storage */
/* xHP: Hermitian indefinite packed */
/* xHB: Hermitian indefinite banded */
/* xSY: Symmetric indefinite, 2-D storage */
/* xSP: Symmetric indefinite packed */
/* xSB: Symmetric indefinite banded */
/* xTR: Triangular */
/* xTP: Triangular packed */
/* xTB: Triangular banded */
/* xQR: General m x n matrix */
/* xLQ: General m x n matrix */
/* xQL: General m x n matrix */
/* xRQ: General m x n matrix */
/* where the leading character indicates the precision. */
/* XTYPE (input) CHARACTER*1 */
/* Specifies how the exact solution X will be determined: */
/* = 'N': New solution; generate a random X. */
/* = 'C': Computed; use value of X on entry. */
/* UPLO (input) CHARACTER*1 */
/* Used only if A is symmetric or triangular; specifies whether */
/* the upper or lower triangular part of the matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Used only if A is nonsymmetric; specifies the operation */
/* applied to the matrix A. */
/* = 'N': B := A * X */
/* = 'T': B := A**T * X */
/* = 'C': B := A**H * X */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* Used only if A is a band matrix; specifies the number of */
/* subdiagonals of A if A is a general band matrix or if A is */
/* symmetric or triangular and UPLO = 'L'; specifies the number */
/* of superdiagonals of A if A is symmetric or triangular and */
/* UPLO = 'U'. 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* Used only if A is a general band matrix or if A is */
/* triangular. */
/* If PATH = xGB, specifies the number of superdiagonals of A, */
/* and 0 <= KU <= N-1. */
/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
/* matrix has unit diagonal: */
/* = 1: matrix has non-unit diagonal (default) */
/* = 2: matrix has unit diagonal */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors in the system A*X = B. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The test matrix whose type is given by PATH. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If PATH = xGB, LDA >= KL+KU+1. */
/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
/* Otherwise, LDA >= max(1,M). */
/* X (input or output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
/* the exact solution to the system of linear equations. */
/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
/* with random values. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
/* B (output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side vector(s) for the system of equations, */
/* computed from B = op(A) * X, where op(A) is determined by */
/* TRANS. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. If TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* ZLATMS). Modified on exit. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--iseed;
/* Function Body */
*info = 0;
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
tran = lsame_(trans, "T") || lsame_(trans, "C");
notran = ! tran;
gen = lsame_(path + 1, "G");
qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
"Q");
sym = lsame_(path + 1, "P") || lsame_(path + 1,
"S") || lsame_(path + 1, "H");
tri = lsame_(path + 1, "T");
band = lsame_(path + 2, "B");
if (! lsame_(c1, "Zomplex precision")) {
*info = -1;
} else if (! (lsame_(xtype, "N") || lsame_(xtype,
"C"))) {
*info = -2;
} else if ((sym || tri) && ! (lsame_(uplo, "U") ||
lsame_(uplo, "L"))) {
*info = -3;
} else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
*info = -4;
} else if (*m < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (band && *kl < 0) {
*info = -7;
} else if (band && *ku < 0) {
*info = -8;
} else if (*nrhs < 0) {
*info = -9;
} else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
kl + 1 || band && gen && *lda < *kl + *ku + 1) {
*info = -11;
} else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
*info = -13;
} else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLARHS", &i__1);
return 0;
}
/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
if (tran) {
nx = *m;
mb = *n;
} else {
nx = *n;
mb = *m;
}
if (! lsame_(xtype, "C")) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
/* L10: */
}
}
/* Multiply X by op( A ) using an appropriate */
/* matrix multiply routine. */
if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
"QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
lsamen_(&c__2, c2, "RQ")) {
/* General matrix */
zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
x_offset], ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
c__2, c2, "HE")) {
/* Hermitian matrix, 2-D storage */
zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "SY")) {
/* Symmetric matrix, 2-D storage */
zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L20: */
}
} else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
c__2, c2, "HB")) {
/* Hermitian matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L30: */
}
} else if (lsamen_(&c__2, c2, "SB")) {
/* Symmetric matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L40: */
}
} else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
c__2, c2, "HP")) {
/* Hermitian matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L50: */
}
} else if (lsamen_(&c__2, c2, "SP")) {
/* Symmetric matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L60: */
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrix. Note that for triangular matrices, */
/* KU = 1 => non-unit triangular */
/* KU = 2 => unit triangular */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular matrix, packed storage */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
c__1);
/* L70: */
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular matrix, banded storage */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ 1], &c__1);
/* L80: */
}
} else {
/* If none of the above, set INFO = -1 and return */
*info = -1;
i__1 = -(*info);
xerbla_("ZLARHS", &i__1);
}
return 0;
/* End of ZLARHS */
} /* zlarhs_ */
/* Subroutine */ int zsprfs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *
b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr,
doublereal *berr, doublecomplex *work, doublereal *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;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k;
doublereal s;
integer ik, kk;
doublereal xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3], count;
logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zspmv_(
char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zlacn2_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */ int zsptrs_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSPRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is symmetric 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*16 array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the symmetric 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*16 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**T or */
/* A = L*D*L**T as computed by ZSPTRF, 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 ZSPTRF. */
/* B (input) COMPLEX*16 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*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZSPTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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_("ZSPRFS", &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.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("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.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, n, &z__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__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__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.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ik;
rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[ik]), abs(d__2))) * xk;
i__4 = ik;
i__5 = i__ + j * x_dim1;
s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
));
++ik;
/* L40: */
}
i__3 = kk + k - 1;
rwork[k] = rwork[k] + ((d__1 = ap[i__3].r, abs(d__1)) + (d__2
= d_imag(&ap[kk + k - 1]), abs(d__2))) * xk + s;
kk += k;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__3 = kk;
rwork[k] += ((d__1 = ap[i__3].r, abs(d__1)) + (d__2 = d_imag(&
ap[kk]), abs(d__2))) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = ik;
rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[ik]), abs(d__2))) * xk;
i__4 = ik;
i__5 = i__ + j * x_dim1;
s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
));
++ik;
/* L60: */
}
rwork[k] += s;
kk += *n - k + 1;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__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. <= lstres && count <= 5) {
/* Update solution and try again. */
zsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
zaxpy_(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 ZLACN2 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__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
zsptrs_(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__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__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__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L120: */
}
zsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZSPRFS */
} /* zsprfs_ */
/* Subroutine */
int zsptri_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublecomplex *work, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
doublecomplex d__;
integer j, k;
doublecomplex t, ak;
integer kc, kp, kx, kpc, npp;
doublecomplex akp1, temp, akkp1;
extern logical lsame_(char *, char *);
integer kstep;
logical upper;
extern /* Subroutine */
int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Double Complex */
VOID zdotu_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zspmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), xerbla_( char *, integer *);
integer kcnext;
/* -- 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--ipiv;
--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_("ZSPTRI", &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[i__1].r == 0. && ap[i__1].i == 0.))
{
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[i__2].r == 0. && ap[i__2].i == 0.))
{
return 0;
}
kp = kp + *n - *info + 1;
/* L20: */
}
}
*info = 0;
if (upper)
{
/* Compute inv(A) from the factorization A = U*D*U**T. */
/* 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;
z_div(&z__1, &c_b1, &ap[kc + k - 1]);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* Compute column K of the inverse. */
if (k > 1)
{
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zspmv_(uplo, &i__1, &z__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;
zdotu_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 1;
}
else
{
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + k - 1;
t.r = ap[i__1].r;
t.i = ap[i__1].i; // , expr subst
z_div(&z__1, &ap[kc + k - 1], &t);
ak.r = z__1.r;
ak.i = z__1.i; // , expr subst
z_div(&z__1, &ap[kcnext + k], &t);
akp1.r = z__1.r;
akp1.i = z__1.i; // , expr subst
z_div(&z__1, &ap[kcnext + k - 1], &t);
akkp1.r = z__1.r;
akkp1.i = z__1.i; // , expr subst
z__3.r = ak.r * akp1.r - ak.i * akp1.i;
z__3.i = ak.r * akp1.i + ak.i * akp1.r; // , expr subst
z__2.r = z__3.r - 1.;
z__2.i = z__3.i - 0.; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
d__.r = z__1.r;
d__.i = z__1.i; // , expr subst
i__1 = kc + k - 1;
z_div(&z__1, &akp1, &d__);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kcnext + k;
z_div(&z__1, &ak, &d__);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kcnext + k - 1;
z__2.r = -akkp1.r;
z__2.i = -akkp1.i; // , expr subst
z_div(&z__1, &z__2, &d__);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* Compute columns K and K+1 of the inverse. */
if (k > 1)
{
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zspmv_(uplo, &i__1, &z__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;
zdotu_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
zdotu_f2c_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = k - 1;
zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zspmv_(uplo, &i__1, &z__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;
zdotu_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 2;
kcnext = kcnext + k + 1;
}
kp = (i__1 = ipiv[k], f2c_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;
zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1;
j <= i__1;
++j)
{
kx = kx + j - 1;
i__2 = kc + j - 1;
temp.r = ap[i__2].r;
temp.i = ap[i__2].i; // , expr subst
i__2 = kc + j - 1;
i__3 = kx;
ap[i__2].r = ap[i__3].r;
ap[i__2].i = ap[i__3].i; // , expr subst
i__2 = kx;
ap[i__2].r = temp.r;
ap[i__2].i = temp.i; // , expr subst
/* L40: */
}
i__1 = kc + k - 1;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kpc + kp - 1;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
if (kstep == 2)
{
i__1 = kc + k + k - 1;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kc + k + kp - 1;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
}
}
k += kstep;
kc = kcnext;
goto L30;
L50:
;
}
else
{
/* Compute inv(A) from the factorization A = L*D*L**T. */
/* 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;
z_div(&z__1, &c_b1, &ap[kc]);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* Compute column K of the inverse. */
if (k < *n)
{
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zspmv_(uplo, &i__1, &z__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;
zdotu_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 1;
}
else
{
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + 1;
t.r = ap[i__1].r;
t.i = ap[i__1].i; // , expr subst
z_div(&z__1, &ap[kcnext], &t);
ak.r = z__1.r;
ak.i = z__1.i; // , expr subst
z_div(&z__1, &ap[kc], &t);
akp1.r = z__1.r;
akp1.i = z__1.i; // , expr subst
z_div(&z__1, &ap[kcnext + 1], &t);
akkp1.r = z__1.r;
akkp1.i = z__1.i; // , expr subst
z__3.r = ak.r * akp1.r - ak.i * akp1.i;
z__3.i = ak.r * akp1.i + ak.i * akp1.r; // , expr subst
z__2.r = z__3.r - 1.;
z__2.i = z__3.i - 0.; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
d__.r = z__1.r;
d__.i = z__1.i; // , expr subst
i__1 = kcnext;
z_div(&z__1, &akp1, &d__);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kc;
z_div(&z__1, &ak, &d__);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kcnext + 1;
z__2.r = -akkp1.r;
z__2.i = -akkp1.i; // , expr subst
z_div(&z__1, &z__2, &d__);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* Compute columns K-1 and K of the inverse. */
if (k < *n)
{
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zspmv_(uplo, &i__1, &z__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;
zdotu_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
zdotu_f2c_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], & c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = *n - k;
zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zspmv_(uplo, &i__1, &z__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;
zdotu_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 2;
kcnext -= *n - k + 3;
}
kp = (i__1 = ipiv[k], f2c_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;
zswap_(&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 <= i__1;
++j)
{
kx = kx + *n - j + 1;
i__2 = kc + j - k;
temp.r = ap[i__2].r;
temp.i = ap[i__2].i; // , expr subst
i__2 = kc + j - k;
i__3 = kx;
ap[i__2].r = ap[i__3].r;
ap[i__2].i = ap[i__3].i; // , expr subst
i__2 = kx;
ap[i__2].r = temp.r;
ap[i__2].i = temp.i; // , expr subst
/* L70: */
}
i__1 = kc;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kpc;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
if (kstep == 2)
{
i__1 = kc - *n + k - 1;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kc - *n + kp - 1;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of ZSPTRI */
}
