/* 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 */ }