int f2c_zhpmv(char* uplo, integer* N, doublecomplex* alpha, doublecomplex* Ap, doublecomplex* X, integer* incX, doublecomplex* beta, doublecomplex* Y, integer* incY) { zhpmv_(uplo, N, alpha, Ap, X, incX, beta, Y, incY); return 0; }
/* Subroutine */ int zhptri_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublecomplex *work, integer *info) { /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1; doublecomplex z__1, z__2; /* Builtin functions */ double z_abs(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ doublereal d__; integer j, k; doublereal t, ak; integer kc, kp, kx, kpc, npp; doublereal akp1; doublecomplex temp, akkp1; extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); integer kstep; logical upper; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zswap_( integer *, doublecomplex *, integer *, 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_("ZHPTRI", &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**H. */ /* K is the main loop index, increasing from 1 to N in steps of */ /* 1 or 2, depending on the size of the diagonal blocks. */ k = 1; kc = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L50; } kcnext = kc + k; if (ipiv[k] > 0) { /* 1 x 1 diagonal block */ /* Invert the diagonal block. */ i__1 = kc + k - 1; i__2 = kc + k - 1; d__1 = 1. / ap[i__2].r; ap[i__1].r = d__1; ap[i__1].i = 0.; // , 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 zhpmv_(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; zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1; z__1.i = ap[i__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. */ t = z_abs(&ap[kcnext + k - 1]); i__1 = kc + k - 1; ak = ap[i__1].r / t; i__1 = kcnext + k; akp1 = ap[i__1].r / t; i__1 = kcnext + k - 1; z__1.r = ap[i__1].r / t; z__1.i = ap[i__1].i / t; // , expr subst akkp1.r = z__1.r; akkp1.i = z__1.i; // , expr subst d__ = t * (ak * akp1 - 1.); i__1 = kc + k - 1; d__1 = akp1 / d__; ap[i__1].r = d__1; ap[i__1].i = 0.; // , expr subst i__1 = kcnext + k; d__1 = ak / d__; ap[i__1].r = d__1; ap[i__1].i = 0.; // , expr subst i__1 = kcnext + k - 1; z__2.r = -akkp1.r; z__2.i = -akkp1.i; // , expr subst z__1.r = z__2.r / d__; z__1.i = z__2.i / d__; // , expr subst 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 zhpmv_(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; zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1; z__1.i = ap[i__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; zdotc_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 zhpmv_(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; zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1; z__1.i = ap[i__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; d_cnjg(&z__1, &ap[kc + j - 1]); temp.r = z__1.r; temp.i = z__1.i; // , expr subst i__2 = kc + j - 1; d_cnjg(&z__1, &ap[kx]); ap[i__2].r = z__1.r; ap[i__2].i = z__1.i; // , expr subst i__2 = kx; ap[i__2].r = temp.r; ap[i__2].i = temp.i; // , expr subst /* L40: */ } i__1 = kc + kp - 1; d_cnjg(&z__1, &ap[kc + kp - 1]); ap[i__1].r = z__1.r; ap[i__1].i = z__1.i; // , expr subst 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**H. */ /* K is the main loop index, increasing from 1 to N in steps of */ /* 1 or 2, depending on the size of the diagonal blocks. */ npp = *n * (*n + 1) / 2; k = *n; kc = npp; L60: /* If K < 1, exit from loop. */ if (k < 1) { goto L80; } kcnext = kc - (*n - k + 2); if (ipiv[k] > 0) { /* 1 x 1 diagonal block */ /* Invert the diagonal block. */ i__1 = kc; i__2 = kc; d__1 = 1. / ap[i__2].r; ap[i__1].r = d__1; ap[i__1].i = 0.; // , 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 zhpmv_(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; zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1; z__1.i = ap[i__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. */ t = z_abs(&ap[kcnext + 1]); i__1 = kcnext; ak = ap[i__1].r / t; i__1 = kc; akp1 = ap[i__1].r / t; i__1 = kcnext + 1; z__1.r = ap[i__1].r / t; z__1.i = ap[i__1].i / t; // , expr subst akkp1.r = z__1.r; akkp1.i = z__1.i; // , expr subst d__ = t * (ak * akp1 - 1.); i__1 = kcnext; d__1 = akp1 / d__; ap[i__1].r = d__1; ap[i__1].i = 0.; // , expr subst i__1 = kc; d__1 = ak / d__; ap[i__1].r = d__1; ap[i__1].i = 0.; // , expr subst i__1 = kcnext + 1; z__2.r = -akkp1.r; z__2.i = -akkp1.i; // , expr subst z__1.r = z__2.r / d__; z__1.i = z__2.i / d__; // , expr subst 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 zhpmv_(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; zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1; z__1.i = ap[i__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; zdotc_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 zhpmv_(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; zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1; z__1.i = ap[i__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; d_cnjg(&z__1, &ap[kc + j - k]); temp.r = z__1.r; temp.i = z__1.i; // , expr subst i__2 = kc + j - k; d_cnjg(&z__1, &ap[kx]); ap[i__2].r = z__1.r; ap[i__2].i = z__1.i; // , expr subst i__2 = kx; ap[i__2].r = temp.r; ap[i__2].i = temp.i; // , expr subst /* L70: */ } i__1 = kc + kp - k; d_cnjg(&z__1, &ap[kc + kp - k]); ap[i__1].r = z__1.r; ap[i__1].i = z__1.i; // , expr subst 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 ZHPTRI */ }
/* Subroutine */ int zpprfs_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *afp, 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 *), zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_( integer *, doublecomplex *, doublecomplex *, integer *, 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 zpptrs_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, integer *); /* -- LAPACK routine (version 3.1) -- */ /* 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 */ /* ======= */ /* ZPPRFS improves the computed solution to a system of linear */ /* equations when the coefficient matrix is Hermitian positive definite */ /* 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 Hermitian matrix A, packed */ /* columnwise in a linear array. The j-th column of A is stored */ /* in the array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ /* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The triangular factor U or L from the Cholesky factorization */ /* A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF, */ /* packed columnwise in a linear array in the same format as A */ /* (see AP). */ /* 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 ZPPTRS. */ /* 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; 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 = -7; } else if (*ldx < max(1,*n)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("ZPPRFS", &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.; zhpmv_(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)) * 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)) * 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. */ zpptrs_(uplo, n, &c__1, &afp[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'). */ zpptrs_(uplo, n, &c__1, &afp[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: */ } zpptrs_(uplo, n, &c__1, &afp[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 ZPPRFS */ } /* zpprfs_ */
/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap, doublereal *d__, doublereal *e, doublecomplex *tau, integer *info) { /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1; doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ integer i__, i1, ii, i1i1; doublecomplex taui; extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *); doublecomplex alpha; extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); logical upper; extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ --tau; --e; --d__; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPTRD", &i__1); return 0; } /* Quick return if possible */ if (*n <= 0) { return 0; } if (upper) { /* Reduce the upper triangle of A. */ /* I1 is the index in AP of A(1,I+1). */ i1 = *n * (*n - 1) / 2 + 1; i__1 = i1 + *n - 1; i__2 = i1 + *n - 1; d__1 = ap[i__2].r; ap[i__1].r = d__1; ap[i__1].i = 0.; // , expr subst for (i__ = *n - 1; i__ >= 1; --i__) { /* Generate elementary reflector H(i) = I - tau * v * v**H */ /* to annihilate A(1:i-1,i+1) */ i__1 = i1 + i__ - 1; alpha.r = ap[i__1].r; alpha.i = ap[i__1].i; // , expr subst zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui); i__1 = i__; e[i__1] = alpha.r; if (taui.r != 0. || taui.i != 0.) { /* Apply H(i) from both sides to A(1:i,1:i) */ i__1 = i1 + i__ - 1; ap[i__1].r = 1.; ap[i__1].i = 0.; // , expr subst /* Compute y := tau * A * v storing y in TAU(1:i) */ zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[ 1], &c__1); /* Compute w := y - 1/2 * tau * (y**H *v) * v */ z__3.r = -.5; z__3.i = -0.; // , expr subst z__2.r = z__3.r * taui.r - z__3.i * taui.i; z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst zdotc_f2c_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1); z__1.r = z__2.r * z__4.r - z__2.i * z__4.i; z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst alpha.r = z__1.r; alpha.i = z__1.i; // , expr subst zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w**H - w * v**H */ z__1.r = -1.; z__1.i = -0.; // , expr subst zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[ 1]); } i__1 = i1 + i__ - 1; i__2 = i__; ap[i__1].r = e[i__2]; ap[i__1].i = 0.; // , expr subst i__1 = i__ + 1; i__2 = i1 + i__; d__[i__1] = ap[i__2].r; i__1 = i__; tau[i__1].r = taui.r; tau[i__1].i = taui.i; // , expr subst i1 -= i__; /* L10: */ } d__[1] = ap[1].r; } else { /* Reduce the lower triangle of A. II is the index in AP of */ /* A(i,i) and I1I1 is the index of A(i+1,i+1). */ ii = 1; d__1 = ap[1].r; ap[1].r = d__1; ap[1].i = 0.; // , expr subst i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i1i1 = ii + *n - i__ + 1; /* Generate elementary reflector H(i) = I - tau * v * v**H */ /* to annihilate A(i+2:n,i) */ i__2 = ii + 1; alpha.r = ap[i__2].r; alpha.i = ap[i__2].i; // , expr subst i__2 = *n - i__; zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui); i__2 = i__; e[i__2] = alpha.r; if (taui.r != 0. || taui.i != 0.) { /* Apply H(i) from both sides to A(i+1:n,i+1:n) */ i__2 = ii + 1; ap[i__2].r = 1.; ap[i__2].i = 0.; // , expr subst /* Compute y := tau * A * v storing y in TAU(i:n-1) */ i__2 = *n - i__; zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & c_b2, &tau[i__], &c__1); /* Compute w := y - 1/2 * tau * (y**H *v) * v */ z__3.r = -.5; z__3.i = -0.; // , expr subst z__2.r = z__3.r * taui.r - z__3.i * taui.i; z__2.i = z__3.r * taui.i + z__3.i * taui.r; // , expr subst i__2 = *n - i__; zdotc_f2c_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1); z__1.r = z__2.r * z__4.r - z__2.i * z__4.i; z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst alpha.r = z__1.r; alpha.i = z__1.i; // , expr subst i__2 = *n - i__; zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w**H - w * v**H */ i__2 = *n - i__; z__1.r = -1.; z__1.i = -0.; // , expr subst zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], & c__1, &ap[i1i1]); } i__2 = ii + 1; i__3 = i__; ap[i__2].r = e[i__3]; ap[i__2].i = 0.; // , expr subst i__2 = i__; i__3 = ii; d__[i__2] = ap[i__3].r; i__2 = i__; tau[i__2].r = taui.r; tau[i__2].i = taui.i; // , expr subst ii = i1i1; /* L20: */ } i__1 = *n; i__2 = ii; d__[i__1] = ap[i__2].r; } return 0; /* End of ZHPTRD */ }
/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap, doublereal *d__, doublereal *e, doublecomplex *tau, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZHPTRD reduces a complex Hermitian matrix A stored in packed form to real symmetric tridiagonal form T by a unitary similarity transformation: Q**H * A * Q = T. Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangle of A is stored; = 'L': Lower triangle of A is stored. N (input) INTEGER The order of the matrix A. N >= 0. AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) On entry, the upper or lower triangle of the Hermitian matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. On exit, if UPLO = 'U', the diagonal and first superdiagonal of A are overwritten by the corresponding elements of the tridiagonal matrix T, and the elements above the first superdiagonal, with the array TAU, represent the unitary matrix Q as a product of elementary reflectors; if UPLO = 'L', the diagonal and first subdiagonal of A are over- written by the corresponding elements of the tridiagonal matrix T, and the elements below the first subdiagonal, with the array TAU, represent the unitary matrix Q as a product of elementary reflectors. See Further Details. D (output) DOUBLE PRECISION array, dimension (N) The diagonal elements of the tridiagonal matrix T: D(i) = A(i,i). E (output) DOUBLE PRECISION array, dimension (N-1) The off-diagonal elements of the tridiagonal matrix T: E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. TAU (output) COMPLEX*16 array, dimension (N-1) The scalar factors of the elementary reflectors (see Further Details). INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Further Details =============== If UPLO = 'U', the matrix Q is represented as a product of elementary reflectors Q = H(n-1) . . . H(2) H(1). Each H(i) has the form H(i) = I - tau * v * v' where tau is a complex scalar, and v is a complex vector with v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, overwriting A(1:i-1,i+1), and tau is stored in TAU(i). If UPLO = 'L', the matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(n-1). Each H(i) has the form H(i) = I - tau * v * v' where tau is a complex scalar, and v is a complex vector with v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, overwriting A(i+2:n,i), and tau is stored in TAU(i). ===================================================================== Test the input parameters Parameter adjustments */ /* Table of constant values */ static doublecomplex c_b2 = {0.,0.}; static integer c__1 = 1; /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1; doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ static doublecomplex taui; extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *); static integer i__; static doublecomplex alpha; extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer i1; static logical upper; extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); static integer ii; extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_( integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); static integer i1i1; --tau; --e; --d__; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPTRD", &i__1); return 0; } /* Quick return if possible */ if (*n <= 0) { return 0; } if (upper) { /* Reduce the upper triangle of A. I1 is the index in AP of A(1,I+1). */ i1 = *n * (*n - 1) / 2 + 1; i__1 = i1 + *n - 1; i__2 = i1 + *n - 1; d__1 = ap[i__2].r; ap[i__1].r = d__1, ap[i__1].i = 0.; for (i__ = *n - 1; i__ >= 1; --i__) { /* Generate elementary reflector H(i) = I - tau * v * v' to annihilate A(1:i-1,i+1) */ i__1 = i1 + i__ - 1; alpha.r = ap[i__1].r, alpha.i = ap[i__1].i; zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui); i__1 = i__; e[i__1] = alpha.r; if (taui.r != 0. || taui.i != 0.) { /* Apply H(i) from both sides to A(1:i,1:i) */ i__1 = i1 + i__ - 1; ap[i__1].r = 1., ap[i__1].i = 0.; /* Compute y := tau * A * v storing y in TAU(1:i) */ zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[ 1], &c__1); /* Compute w := y - 1/2 * tau * (y'*v) * v */ z__3.r = -.5, z__3.i = 0.; z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * taui.i + z__3.i * taui.r; zdotc_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1); z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; alpha.r = z__1.r, alpha.i = z__1.i; zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); /* Apply the transformation as a rank-2 update: A := A - v * w' - w * v' */ z__1.r = -1., z__1.i = 0.; zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[ 1]); } i__1 = i1 + i__ - 1; i__2 = i__; ap[i__1].r = e[i__2], ap[i__1].i = 0.; i__1 = i__ + 1; i__2 = i1 + i__; d__[i__1] = ap[i__2].r; i__1 = i__; tau[i__1].r = taui.r, tau[i__1].i = taui.i; i1 -= i__; /* L10: */ } d__[1] = ap[1].r; } else { /* Reduce the lower triangle of A. II is the index in AP of A(i,i) and I1I1 is the index of A(i+1,i+1). */ ii = 1; d__1 = ap[1].r; ap[1].r = d__1, ap[1].i = 0.; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i1i1 = ii + *n - i__ + 1; /* Generate elementary reflector H(i) = I - tau * v * v' to annihilate A(i+2:n,i) */ i__2 = ii + 1; alpha.r = ap[i__2].r, alpha.i = ap[i__2].i; i__2 = *n - i__; zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui); i__2 = i__; e[i__2] = alpha.r; if (taui.r != 0. || taui.i != 0.) { /* Apply H(i) from both sides to A(i+1:n,i+1:n) */ i__2 = ii + 1; ap[i__2].r = 1., ap[i__2].i = 0.; /* Compute y := tau * A * v storing y in TAU(i:n-1) */ i__2 = *n - i__; zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & c_b2, &tau[i__], &c__1); /* Compute w := y - 1/2 * tau * (y'*v) * v */ z__3.r = -.5, z__3.i = 0.; z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * taui.i + z__3.i * taui.r; i__2 = *n - i__; zdotc_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1); z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; alpha.r = z__1.r, alpha.i = z__1.i; i__2 = *n - i__; zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); /* Apply the transformation as a rank-2 update: A := A - v * w' - w * v' */ i__2 = *n - i__; z__1.r = -1., z__1.i = 0.; zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], & c__1, &ap[i1i1]); } i__2 = ii + 1; i__3 = i__; ap[i__2].r = e[i__3], ap[i__2].i = 0.; i__2 = i__; i__3 = ii; d__[i__2] = ap[i__3].r; i__2 = i__; tau[i__2].r = taui.r, tau[i__2].i = taui.i; ii = i1i1; /* L20: */ } i__1 = *n; i__2 = ii; d__[i__1] = ap[i__2].r; } return 0; /* End of ZHPTRD */ } /* zhptrd_ */
void zhpmv(char uplo, int n, doublecomplex *alpha, doublecomplex *ap, doublecomplex *x, int incx, doublecomplex *beta, doublecomplex *y, int incy) { zhpmv_( &uplo, &n, alpha, ap, x, &incx, beta, y, &incy ); }
/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, integer *info) { /* System generated locals */ integer i__1, i__2, i__3, i__4; doublereal d__1, d__2; doublecomplex z__1, z__2, z__3; /* Local variables */ integer j, k, j1, k1, jj, kk; doublecomplex ct; doublereal ajj; integer j1j1; doublereal akk; integer k1k1; doublereal bjj, bkk; extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *); extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); logical upper; extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * , doublecomplex *, integer *), xerbla_( char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZHPGST reduces a complex Hermitian-definite generalized */ /* eigenproblem to standard form, using packed storage. */ /* If ITYPE = 1, the problem is A*x = lambda*B*x, */ /* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */ /* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ /* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */ /* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */ /* = 2 or 3: compute U*A*U**H or L**H*A*L. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored and B is factored as */ /* U**H*U; */ /* = 'L': Lower triangle of A is stored and B is factored as */ /* L*L**H. */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the Hermitian matrix */ /* A, packed columnwise in a linear array. The j-th column of A */ /* is stored in the array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ /* On exit, if INFO = 0, the transformed matrix, stored in the */ /* same format as A. */ /* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The triangular factor from the Cholesky factorization of B, */ /* stored in the same format as A, as returned by ZPPTRF. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --bp; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ /* J1 and JJ are the indices of A(1,j) and A(j,j) */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1 = jj + 1; jj += j; /* Compute the j-th column of the upper triangle of A */ i__2 = jj; i__3 = jj; d__1 = ap[i__3].r; ap[i__2].r = d__1, ap[i__2].i = 0.; i__2 = jj; bjj = bp[i__2].r; ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1); i__2 = j - 1; z__1.r = -1., z__1.i = -0.; zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1); i__2 = j - 1; d__1 = 1. / bjj; zdscal_(&i__2, &d__1, &ap[j1], &c__1); i__2 = jj; i__3 = jj; i__4 = j - 1; zdotc_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1); z__2.r = ap[i__3].r - z__3.r, z__2.i = ap[i__3].i - z__3.i; z__1.r = z__2.r / bjj, z__1.i = z__2.i / bjj; ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ /* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ kk = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1k1 = kk + *n - k + 1; /* Update the lower triangle of A(k:n,k:n) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = kk; ap[i__2].r = akk, ap[i__2].i = 0.; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1); d__1 = akk * -.5; ct.r = d__1, ct.i = 0.; i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; z__1.r = -1., z__1.i = -0.; zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]); i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ /* K1 and KK are the indices of A(1,k) and A(k,k) */ kk = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1 = kk + 1; kk += k; /* Update the upper triangle of A(1:k,1:k) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; i__2 = k - 1; ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1); d__1 = akk * .5; ct.r = d__1, ct.i = 0.; i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]); i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zdscal_(&i__2, &bkk, &ap[k1], &c__1); i__2 = kk; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); ap[i__2].r = d__1, ap[i__2].i = 0.; /* L30: */ } } else { /* Compute L'*A*L */ /* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1j1 = jj + *n - j + 1; /* Compute the j-th column of the lower triangle of A */ i__2 = jj; ajj = ap[i__2].r; i__2 = jj; bjj = bp[i__2].r; i__2 = jj; d__1 = ajj * bjj; i__3 = *n - j; zdotc_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); z__1.r = d__1 + z__2.r, z__1.i = z__2.i; ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; i__2 = *n - j; zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1); i__2 = *n - j + 1; ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of ZHPGST */ } /* zhpgst_ */
/* Subroutine */ int 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 zhptri_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublecomplex *work, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZHPTRI computes the inverse of a complex Hermitian indefinite matrix A in packed storage using the factorization A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 'U': Upper triangular, form is A = U*D*U**H; = 'L': Lower triangular, form is A = L*D*L**H. N (input) INTEGER The order of the matrix A. N >= 0. AP (input/output) COMPLEX*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 ZHPTRF, stored as a packed triangular matrix. On exit, if INFO = 0, the (Hermitian) inverse of the original matrix, stored as a packed triangular matrix. The j-th column of inv(A) is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. IPIV (input) INTEGER array, dimension (N) Details of the interchanges and the block structure of D as determined by ZHPTRF. 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 */ /* Table of constant values */ static doublecomplex c_b2 = {0.,0.}; static integer c__1 = 1; /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1; doublecomplex z__1, z__2; /* Builtin functions */ double z_abs(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ static doublecomplex temp, akkp1; static doublereal d__; static integer j, k; static doublereal t; extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer kstep; static logical upper; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zswap_( integer *, doublecomplex *, integer *, doublecomplex *, integer *) ; static doublereal ak; static integer kc, kp, kx; extern /* Subroutine */ int xerbla_(char *, integer *); static integer kcnext, kpc, npp; static doublereal akp1; --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_("ZHPTRI", &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'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = 1; kc = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L50; } kcnext = kc + k; if (ipiv[k] > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ i__1 = kc + k - 1; i__2 = kc + k - 1; d__1 = 1. / ap[i__2].r; ap[i__1].r = d__1, ap[i__1].i = 0.; /* 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.; zhpmv_(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; zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__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. */ t = z_abs(&ap[kcnext + k - 1]); i__1 = kc + k - 1; ak = ap[i__1].r / t; i__1 = kcnext + k; akp1 = ap[i__1].r / t; i__1 = kcnext + k - 1; z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t; akkp1.r = z__1.r, akkp1.i = z__1.i; d__ = t * (ak * akp1 - 1.); i__1 = kc + k - 1; d__1 = akp1 / d__; ap[i__1].r = d__1, ap[i__1].i = 0.; i__1 = kcnext + k; d__1 = ak / d__; ap[i__1].r = d__1, ap[i__1].i = 0.; i__1 = kcnext + k - 1; z__2.r = -akkp1.r, z__2.i = -akkp1.i; z__1.r = z__2.r / d__, z__1.i = z__2.i / 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.; zhpmv_(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; zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__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; zdotc_(&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.; zhpmv_(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; zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__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; d_cnjg(&z__1, &ap[kc + j - 1]); temp.r = z__1.r, temp.i = z__1.i; i__2 = kc + j - 1; d_cnjg(&z__1, &ap[kx]); ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; i__2 = kx; ap[i__2].r = temp.r, ap[i__2].i = temp.i; /* L40: */ } i__1 = kc + kp - 1; d_cnjg(&z__1, &ap[kc + kp - 1]); ap[i__1].r = z__1.r, ap[i__1].i = z__1.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; i__2 = kc; d__1 = 1. / ap[i__2].r; ap[i__1].r = d__1, ap[i__1].i = 0.; /* 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.; zhpmv_(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; zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__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. */ t = z_abs(&ap[kcnext + 1]); i__1 = kcnext; ak = ap[i__1].r / t; i__1 = kc; akp1 = ap[i__1].r / t; i__1 = kcnext + 1; z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t; akkp1.r = z__1.r, akkp1.i = z__1.i; d__ = t * (ak * akp1 - 1.); i__1 = kcnext; d__1 = akp1 / d__; ap[i__1].r = d__1, ap[i__1].i = 0.; i__1 = kc; d__1 = ak / d__; ap[i__1].r = d__1, ap[i__1].i = 0.; i__1 = kcnext + 1; z__2.r = -akkp1.r, z__2.i = -akkp1.i; z__1.r = z__2.r / d__, z__1.i = z__2.i / 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.; zhpmv_(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; zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__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; zdotc_(&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.; zhpmv_(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; zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1); d__1 = z__2.r; z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__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; d_cnjg(&z__1, &ap[kc + j - k]); temp.r = z__1.r, temp.i = z__1.i; i__2 = kc + j - k; d_cnjg(&z__1, &ap[kx]); ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; i__2 = kx; ap[i__2].r = temp.r, ap[i__2].i = temp.i; /* L70: */ } i__1 = kc + kp - k; d_cnjg(&z__1, &ap[kc + kp - k]); ap[i__1].r = z__1.r, ap[i__1].i = z__1.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 ZHPTRI */ } /* zhptri_ */
/* Subroutine */ int zhprfs_(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 *), zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_( integer *, doublecomplex *, doublecomplex *, integer *, 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 zhptrs_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. 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_("ZHPRFS", &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.; // , expr subst zhpmv_(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) ( f2c_abs(R(i)) / ( f2c_abs(A)*f2c_abs(X) + f2c_abs(B) )(i) ) */ /* where f2c_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, f2c_abs(d__1)) + (d__2 = d_imag(&b[ i__ + j * b_dim1]), f2c_abs(d__2)); /* L30: */ } /* Compute f2c_abs(A)*f2c_abs(X) + f2c_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, f2c_abs(d__1)) + (d__2 = d_imag(&x[k + j * x_dim1]), f2c_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, f2c_abs(d__1)) + (d__2 = d_imag(&ap[ik]), f2c_abs(d__2))) * xk; i__4 = ik; i__5 = i__ + j * x_dim1; s += ((d__1 = ap[i__4].r, f2c_abs(d__1)) + (d__2 = d_imag(&ap[ ik]), f2c_abs(d__2))) * ((d__3 = x[i__5].r, f2c_abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), f2c_abs(d__4) )); ++ik; /* L40: */ } i__3 = kk + k - 1; rwork[k] = rwork[k] + (d__1 = ap[i__3].r, f2c_abs(d__1)) * 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, f2c_abs(d__1)) + (d__2 = d_imag(&x[k + j * x_dim1]), f2c_abs(d__2)); i__3 = kk; rwork[k] += (d__1 = ap[i__3].r, f2c_abs(d__1)) * 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, f2c_abs(d__1)) + (d__2 = d_imag(&ap[ik]), f2c_abs(d__2))) * xk; i__4 = ik; i__5 = i__ + j * x_dim1; s += ((d__1 = ap[i__4].r, f2c_abs(d__1)) + (d__2 = d_imag(&ap[ ik]), f2c_abs(d__2))) * ((d__3 = x[i__5].r, f2c_abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), f2c_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, f2c_abs(d__1)) + (d__2 = d_imag(&work[i__]), f2c_abs(d__2))) / rwork[i__]; // , expr subst s = max(d__3,d__4); } else { /* Computing MAX */ i__3 = i__; d__3 = s; d__4 = ((d__1 = work[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag(&work[i__]), f2c_abs(d__2)) + safe1) / (rwork[i__] + safe1); // , expr subst 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. */ zhptrs_(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( f2c_abs(inv(A))* */ /* ( f2c_abs(R) + NZ*EPS*( f2c_abs(A)*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */ /* where */ /* norm(Z) is the magnitude of the largest component of Z */ /* inv(A) is the inverse of A */ /* f2c_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 f2c_abs(R)+NZ*EPS*(f2c_abs(A)*f2c_abs(X)+f2c_abs(B)) */ /* is incremented by SAFE1 if the i-th component of */ /* f2c_abs(A)*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */ /* Use ZLACN2 to estimate the infinity-norm of the matrix */ /* inv(A) * diag(W), */ /* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(A)*f2c_abs(X)+f2c_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, f2c_abs(d__1)) + (d__2 = d_imag(&work[i__]), f2c_abs(d__2)) + nz * eps * rwork[i__] ; } else { i__3 = i__; rwork[i__] = (d__1 = work[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag(&work[i__]), f2c_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**H). */ zhptrs_(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; // , expr subst work[i__3].r = z__1.r; work[i__3].i = z__1.i; // , expr subst /* 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; // , expr subst work[i__3].r = z__1.r; work[i__3].i = z__1.i; // , expr subst /* L120: */ } zhptrs_(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, f2c_abs(d__1)) + (d__2 = d_imag(&x[i__ + j * x_dim1]), f2c_abs(d__2)); // , expr subst lstres = max(d__3,d__4); /* L130: */ } if (lstres != 0.) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of ZHPRFS */ }
/* Subroutine */ int zppt02_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1; doublereal d__1, d__2; doublecomplex z__1; /* Local variables */ integer j; doublereal eps, anorm, bnorm, xnorm; extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); extern doublereal dlamch_(char *), zlanhp_(char *, char *, integer *, doublecomplex *, doublereal *), dzasum_(integer *, doublecomplex *, integer *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZPPT02 computes the residual in the solution of a Hermitian system */ /* of linear equations A*x = b when packed storage is used for the */ /* coefficient matrix. The ratio computed is */ /* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */ /* where EPS is the machine precision. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* Hermitian matrix A is stored: */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* N (input) INTEGER */ /* The number of rows and columns of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of columns of B, the matrix of right hand sides. */ /* NRHS >= 0. */ /* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The original Hermitian matrix A, stored as a packed */ /* triangular matrix. */ /* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */ /* The computed solution vectors for the system of linear */ /* equations. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */ /* On entry, the right hand side vectors for the system of */ /* linear equations. */ /* On exit, B is overwritten with the difference B - A*X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* RESID (output) DOUBLE PRECISION */ /* The maximum over the number of right hand sides of */ /* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0 or NRHS = 0. */ /* Parameter adjustments */ --a; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --rwork; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { *resid = 0.; return 0; } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = dlamch_("Epsilon"); anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]); if (anorm <= 0.) { *resid = 1. / eps; return 0; } /* Compute B - A*X for the matrix of right hand sides B. */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { z__1.r = -1., z__1.i = -0.; zhpmv_(uplo, n, &z__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j * b_dim1 + 1], &c__1); /* L10: */ } /* Compute the maximum over the number of right hand sides of */ /* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */ *resid = 0.; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1); xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1); if (xnorm <= 0.) { *resid = 1. / eps; } else { /* Computing MAX */ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps; *resid = max(d__1,d__2); } /* L20: */ } return 0; /* End of ZPPT02 */ } /* zppt02_ */
/* Subroutine */ int zhpt21_(integer *itype, char *uplo, integer *n, integer * kband, doublecomplex *ap, doublereal *d__, doublereal *e, doublecomplex *u, integer *ldu, doublecomplex *vp, doublecomplex *tau, doublecomplex *work, doublereal *rwork, doublereal *result) { /* System generated locals */ integer u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2; doublecomplex z__1, z__2, z__3; /* Local variables */ static doublereal unfl; static doublecomplex temp; extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *), zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *); static integer j; extern logical lsame_(char *, char *); static integer iinfo; static doublereal anorm; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static char cuplo[1]; static doublecomplex vsave; extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static logical lower; static doublereal wnorm; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_( integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal dlamch_(char *); static integer jp, jr; extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *), zlanhp_(char *, char *, integer *, doublecomplex *, doublereal *); extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); static integer jp1; extern /* Subroutine */ int zupmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); static integer lap; static doublereal ulp; #define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1 #define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZHPT21 generally checks a decomposition of the form A = U S U* where * means conjugate transpose, A is hermitian, U is unitary, and S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as a dense matrix, otherwise the U is expressed as a product of Householder transformations, whose vectors are stored in the array "V" and whose scaling constants are in "TAU"; we shall use the letter "V" to refer to the product of Householder transformations (which should be equal to U). Specifically, if ITYPE=1, then: RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* RESULT(2) = | I - UU* | / ( n ulp ) If ITYPE=2, then: RESULT(1) = | A - V S V* | / ( |A| n ulp ) If ITYPE=3, then: RESULT(1) = | I - UV* | / ( n ulp ) Packed storage means that, for example, if UPLO='U', then the columns of the upper triangle of A are stored one after another, so that A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if UPLO='L', then the columns of the lower triangle of A are stored one after another in AP, so that A(j+1,j+1) immediately follows A(n,j) in the array AP. This means that A(i,j) is stored in: AP( i + j*(j-1)/2 ) if UPLO='U' AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L' The array VP bears the same relation to the matrix V that A does to AP. For ITYPE > 1, the transformation U is expressed as a product of Householder transformations: If UPLO='U', then V = H(n-1)...H(1), where H(j) = I - tau(j) v(j) v(j)* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1), (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ), the j-th element is 1, and the last n-j elements are 0. If UPLO='L', then V = H(1)...H(n-1), where H(j) = I - tau(j) v(j) v(j)* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e., in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .) Arguments ========= ITYPE (input) INTEGER Specifies the type of tests to be performed. 1: U expressed as a dense unitary matrix: RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* RESULT(2) = | I - UU* | / ( n ulp ) 2: U expressed as a product V of Housholder transformations: RESULT(1) = | A - V S V* | / ( |A| n ulp ) 3: U expressed both as a dense unitary matrix and as a product of Housholder transformations: RESULT(1) = | I - UV* | / ( n ulp ) UPLO (input) CHARACTER If UPLO='U', the upper triangle of A and V will be used and the (strictly) lower triangle will not be referenced. If UPLO='L', the lower triangle of A and V will be used and the (strictly) upper triangle will not be referenced. N (input) INTEGER The size of the matrix. If it is zero, ZHPT21 does nothing. It must be at least zero. KBAND (input) INTEGER The bandwidth of the matrix. It may only be zero or one. If zero, then S is diagonal, and E is not referenced. If one, then S is symmetric tri-diagonal. AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) The original (unfactored) matrix. It is assumed to be hermitian, and contains the columns of just the upper triangle (UPLO='U') or only the lower triangle (UPLO='L'), packed one after another. D (input) DOUBLE PRECISION array, dimension (N) The diagonal of the (symmetric tri-) diagonal matrix. E (input) DOUBLE PRECISION array, dimension (N) The off-diagonal of the (symmetric tri-) diagonal matrix. E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and (3,2) element, etc. Not referenced if KBAND=0. U (input) COMPLEX*16 array, dimension (LDU, N) If ITYPE=1 or 3, this contains the unitary matrix in the decomposition, expressed as a dense matrix. If ITYPE=2, then it is not referenced. LDU (input) INTEGER The leading dimension of U. LDU must be at least N and at least 1. VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) If ITYPE=2 or 3, the columns of this array contain the Householder vectors used to describe the unitary matrix in the decomposition, as described in purpose. *NOTE* If ITYPE=2 or 3, V is modified and restored. The subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') is set to one, and later reset to its original value, during the course of the calculation. If ITYPE=1, then it is neither referenced nor modified. TAU (input) COMPLEX*16 array, dimension (N) If ITYPE >= 2, then TAU(j) is the scalar factor of v(j) v(j)* in the Householder transformation H(j) of the product U = H(1)...H(n-2) If ITYPE < 2, then TAU is not referenced. WORK (workspace) COMPLEX*16 array, dimension (N**2) Workspace. RWORK (workspace) DOUBLE PRECISION array, dimension (N) Workspace. RESULT (output) DOUBLE PRECISION array, dimension (2) The values computed by the two tests described above. The values are currently limited to 1/ulp, to avoid overflow. RESULT(1) is always modified. RESULT(2) is modified only if ITYPE=1. ===================================================================== Constants Parameter adjustments */ --ap; --d__; --e; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; --vp; --tau; --work; --rwork; --result; /* Function Body */ result[1] = 0.; if (*itype == 1) { result[2] = 0.; } if (*n <= 0) { return 0; } lap = *n * (*n + 1) / 2; if (lsame_(uplo, "U")) { lower = FALSE_; *(unsigned char *)cuplo = 'U'; } else { lower = TRUE_; *(unsigned char *)cuplo = 'L'; } unfl = dlamch_("Safe minimum"); ulp = dlamch_("Epsilon") * dlamch_("Base"); /* Some Error Checks */ if (*itype < 1 || *itype > 3) { result[1] = 10. / ulp; return 0; } /* Do Test 1 Norm of A: */ if (*itype == 3) { anorm = 1.; } else { /* Computing MAX */ d__1 = zlanhp_("1", cuplo, n, &ap[1], &rwork[1]) ; anorm = max(d__1,unfl); } /* Compute error matrix: */ if (*itype == 1) { /* ITYPE=1: error = A - U S U* */ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n); zcopy_(&lap, &ap[1], &c__1, &work[1], &c__1); i__1 = *n; for (j = 1; j <= i__1; ++j) { d__1 = -d__[j]; zhpr_(cuplo, n, &d__1, &u_ref(1, j), &c__1, &work[1]); /* L10: */ } if (*n > 1 && *kband == 1) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = j; z__2.r = e[i__2], z__2.i = 0.; z__1.r = -z__2.r, z__1.i = -z__2.i; zhpr2_(cuplo, n, &z__1, &u_ref(1, j), &c__1, &u_ref(1, j - 1), &c__1, &work[1]); /* L20: */ } } wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]); } else if (*itype == 2) { /* ITYPE=2: error = V S V* - A */ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n); if (lower) { i__1 = lap; i__2 = *n; work[i__1].r = d__[i__2], work[i__1].i = 0.; for (j = *n - 1; j >= 1; --j) { jp = ((*n << 1) - j) * (j - 1) / 2; jp1 = jp + *n - j; if (*kband == 1) { i__1 = jp + j + 1; i__2 = j; z__2.r = 1. - tau[i__2].r, z__2.i = 0. - tau[i__2].i; i__3 = j; z__1.r = e[i__3] * z__2.r, z__1.i = e[i__3] * z__2.i; work[i__1].r = z__1.r, work[i__1].i = z__1.i; i__1 = *n; for (jr = j + 2; jr <= i__1; ++jr) { i__2 = jp + jr; i__3 = j; z__3.r = -tau[i__3].r, z__3.i = -tau[i__3].i; i__4 = j; z__2.r = e[i__4] * z__3.r, z__2.i = e[i__4] * z__3.i; i__5 = jp + jr; z__1.r = z__2.r * vp[i__5].r - z__2.i * vp[i__5].i, z__1.i = z__2.r * vp[i__5].i + z__2.i * vp[ i__5].r; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L30: */ } } i__1 = j; if (tau[i__1].r != 0. || tau[i__1].i != 0.) { i__1 = jp + j + 1; vsave.r = vp[i__1].r, vsave.i = vp[i__1].i; i__1 = jp + j + 1; vp[i__1].r = 1., vp[i__1].i = 0.; i__1 = *n - j; zhpmv_("L", &i__1, &c_b2, &work[jp1 + j + 1], &vp[jp + j + 1], &c__1, &c_b1, &work[lap + 1], &c__1); i__1 = j; z__2.r = tau[i__1].r * -.5, z__2.i = tau[i__1].i * -.5; i__2 = *n - j; zdotc_(&z__3, &i__2, &work[lap + 1], &c__1, &vp[jp + j + 1], &c__1); z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + z__2.i * z__3.r; temp.r = z__1.r, temp.i = z__1.i; i__1 = *n - j; zaxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap + 1], &c__1); i__1 = *n - j; i__2 = j; z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; zhpr2_("L", &i__1, &z__1, &vp[jp + j + 1], &c__1, &work[ lap + 1], &c__1, &work[jp1 + j + 1]); i__1 = jp + j + 1; vp[i__1].r = vsave.r, vp[i__1].i = vsave.i; } i__1 = jp + j; i__2 = j; work[i__1].r = d__[i__2], work[i__1].i = 0.; /* L40: */ } } else { work[1].r = d__[1], work[1].i = 0.; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { jp = j * (j - 1) / 2; jp1 = jp + j; if (*kband == 1) { i__2 = jp1 + j; i__3 = j; z__2.r = 1. - tau[i__3].r, z__2.i = 0. - tau[i__3].i; i__4 = j; z__1.r = e[i__4] * z__2.r, z__1.i = e[i__4] * z__2.i; work[i__2].r = z__1.r, work[i__2].i = z__1.i; i__2 = j - 1; for (jr = 1; jr <= i__2; ++jr) { i__3 = jp1 + jr; i__4 = j; z__3.r = -tau[i__4].r, z__3.i = -tau[i__4].i; i__5 = j; z__2.r = e[i__5] * z__3.r, z__2.i = e[i__5] * z__3.i; i__6 = jp1 + jr; z__1.r = z__2.r * vp[i__6].r - z__2.i * vp[i__6].i, z__1.i = z__2.r * vp[i__6].i + z__2.i * vp[ i__6].r; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L50: */ } } i__2 = j; if (tau[i__2].r != 0. || tau[i__2].i != 0.) { i__2 = jp1 + j; vsave.r = vp[i__2].r, vsave.i = vp[i__2].i; i__2 = jp1 + j; vp[i__2].r = 1., vp[i__2].i = 0.; zhpmv_("U", &j, &c_b2, &work[1], &vp[jp1 + 1], &c__1, & c_b1, &work[lap + 1], &c__1); i__2 = j; z__2.r = tau[i__2].r * -.5, z__2.i = tau[i__2].i * -.5; zdotc_(&z__3, &j, &work[lap + 1], &c__1, &vp[jp1 + 1], & c__1); z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + z__2.i * z__3.r; temp.r = z__1.r, temp.i = z__1.i; zaxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], & c__1); i__2 = j; z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; zhpr2_("U", &j, &z__1, &vp[jp1 + 1], &c__1, &work[lap + 1] , &c__1, &work[1]); i__2 = jp1 + j; vp[i__2].r = vsave.r, vp[i__2].i = vsave.i; } i__2 = jp1 + j + 1; i__3 = j + 1; work[i__2].r = d__[i__3], work[i__2].i = 0.; /* L60: */ } } i__1 = lap; for (j = 1; j <= i__1; ++j) { i__2 = j; i__3 = j; i__4 = j; z__1.r = work[i__3].r - ap[i__4].r, z__1.i = work[i__3].i - ap[ i__4].i; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L70: */ } wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]); } else if (*itype == 3) { /* ITYPE=3: error = U V* - I */ if (*n < 2) { return 0; } zlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n); /* Computing 2nd power */ i__1 = *n; zupmtr_("R", cuplo, "C", n, n, &vp[1], &tau[1], &work[1], n, &work[ i__1 * i__1 + 1], &iinfo); if (iinfo != 0) { result[1] = 10. / ulp; return 0; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = (*n + 1) * (j - 1) + 1; i__3 = (*n + 1) * (j - 1) + 1; z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i + 0.; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L80: */ } wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]); } if (anorm > wnorm) { result[1] = wnorm / anorm / (*n * ulp); } else { if (anorm < 1.) { /* Computing MIN */ d__1 = wnorm, d__2 = *n * anorm; result[1] = min(d__1,d__2) / anorm / (*n * ulp); } else { /* Computing MIN */ d__1 = wnorm / anorm, d__2 = (doublereal) (*n); result[1] = min(d__1,d__2) / (*n * ulp); } } /* Do Test 2 Compute UU* - I */ if (*itype == 1) { zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &c_b1, &work[1], n); i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = (*n + 1) * (j - 1) + 1; i__3 = (*n + 1) * (j - 1) + 1; z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i + 0.; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L90: */ } /* Computing MIN */ d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = ( doublereal) (*n); result[2] = min(d__1,d__2) / (*n * ulp); } return 0; /* End of ZHPT21 */ } /* zhpt21_ */
/* Subroutine */ int zppt03_(char *uplo, integer *n, doublecomplex *a, doublecomplex *ainv, doublecomplex *work, integer *ldwork, doublereal *rwork, doublereal *rcond, doublereal *resid) { /* System generated locals */ integer work_dim1, work_offset, i__1, i__2, i__3; doublecomplex z__1; /* Builtin functions */ void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ integer i__, j, jj; doublereal eps; extern logical lsame_(char *, char *); doublereal anorm; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); extern doublereal dlamch_(char *), zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); doublereal ainvnm; extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *, doublereal *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZPPT03 computes the residual for a Hermitian packed matrix times its */ /* inverse: */ /* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */ /* where EPS is the machine epsilon. */ /* Arguments */ /* ========== */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* Hermitian matrix A is stored: */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* N (input) INTEGER */ /* The number of rows and columns of the matrix A. N >= 0. */ /* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The original Hermitian matrix A, stored as a packed */ /* triangular matrix. */ /* AINV (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The (Hermitian) inverse of the matrix A, stored as a packed */ /* triangular matrix. */ /* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */ /* LDWORK (input) INTEGER */ /* The leading dimension of the array WORK. LDWORK >= max(1,N). */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* RCOND (output) DOUBLE PRECISION */ /* The reciprocal of the condition number of A, computed as */ /* ( 1/norm(A) ) / norm(AINV). */ /* RESID (output) DOUBLE PRECISION */ /* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0. */ /* Parameter adjustments */ --a; --ainv; work_dim1 = *ldwork; work_offset = 1 + work_dim1; work -= work_offset; --rwork; /* Function Body */ if (*n <= 0) { *rcond = 1.; *resid = 0.; return 0; } /* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */ eps = dlamch_("Epsilon"); anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]); ainvnm = zlanhp_("1", uplo, n, &ainv[1], &rwork[1]); if (anorm <= 0. || ainvnm <= 0.) { *rcond = 0.; *resid = 1. / eps; return 0; } *rcond = 1. / anorm / ainvnm; /* UPLO = 'U': */ /* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */ /* expand it to a full matrix, then multiply by A one column at a */ /* time, moving the result one column to the left. */ if (lsame_(uplo, "U")) { /* Copy AINV */ jj = 1; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { zcopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], & c__1); i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + (i__ + 1) * work_dim1; d_cnjg(&z__1, &ainv[jj + i__ - 1]); work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L10: */ } jj += j; /* L20: */ } jj = (*n - 1) * *n / 2 + 1; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n + (i__ + 1) * work_dim1; d_cnjg(&z__1, &ainv[jj + i__ - 1]); work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L30: */ } /* Multiply by A */ i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { z__1.r = -1., z__1.i = -0.; zhpmv_("Upper", n, &z__1, &a[1], &work[(j + 1) * work_dim1 + 1], & c__1, &c_b1, &work[j * work_dim1 + 1], &c__1); /* L40: */ } z__1.r = -1., z__1.i = -0.; zhpmv_("Upper", n, &z__1, &a[1], &ainv[jj], &c__1, &c_b1, &work[*n * work_dim1 + 1], &c__1); /* UPLO = 'L': */ /* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */ /* and multiply by A, moving each column to the right. */ } else { /* Copy AINV */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ * work_dim1 + 1; d_cnjg(&z__1, &ainv[i__ + 1]); work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L50: */ } jj = *n + 1; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = *n - j + 1; zcopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], & c__1); i__2 = *n - j; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + (j + i__ - 1) * work_dim1; d_cnjg(&z__1, &ainv[jj + i__]); work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L60: */ } jj = jj + *n - j + 1; /* L70: */ } /* Multiply by A */ for (j = *n; j >= 2; --j) { z__1.r = -1., z__1.i = -0.; zhpmv_("Lower", n, &z__1, &a[1], &work[(j - 1) * work_dim1 + 1], & c__1, &c_b1, &work[j * work_dim1 + 1], &c__1); /* L80: */ } z__1.r = -1., z__1.i = -0.; zhpmv_("Lower", n, &z__1, &a[1], &ainv[1], &c__1, &c_b1, &work[ work_dim1 + 1], &c__1); } /* Add the identity matrix to WORK . */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * work_dim1; i__3 = i__ + i__ * work_dim1; z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L90: */ } /* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */ *resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]); *resid = *resid * *rcond / eps / (doublereal) (*n); return 0; /* End of ZPPT03 */ } /* zppt03_ */
/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, integer *info) { /* System generated locals */ integer i__1, i__2, i__3, i__4; doublereal d__1, d__2; doublecomplex z__1, z__2, z__3; /* Local variables */ integer j, k, j1, k1, jj, kk; doublecomplex ct; doublereal ajj; integer j1j1; doublereal akk; integer k1k1; doublereal bjj, bkk; extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *); extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); logical upper; extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * , doublecomplex *, integer *), xerbla_( char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *); /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --bp; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U**H)*A*inv(U) */ /* J1 and JJ are the indices of A(1,j) and A(j,j) */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1 = jj + 1; jj += j; /* Compute the j-th column of the upper triangle of A */ i__2 = jj; i__3 = jj; d__1 = ap[i__3].r; ap[i__2].r = d__1; ap[i__2].i = 0.; // , expr subst i__2 = jj; bjj = bp[i__2].r; ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1); i__2 = j - 1; z__1.r = -1.; z__1.i = -0.; // , expr subst zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1); i__2 = j - 1; d__1 = 1. / bjj; zdscal_(&i__2, &d__1, &ap[j1], &c__1); i__2 = jj; i__3 = jj; i__4 = j - 1; zdotc_f2c_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1); z__2.r = ap[i__3].r - z__3.r; z__2.i = ap[i__3].i - z__3.i; // , expr subst z__1.r = z__2.r / bjj; z__1.i = z__2.i / bjj; // , expr subst ap[i__2].r = z__1.r; ap[i__2].i = z__1.i; // , expr subst /* L10: */ } } else { /* Compute inv(L)*A*inv(L**H) */ /* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ kk = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1k1 = kk + *n - k + 1; /* Update the lower triangle of A(k:n,k:n) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = kk; ap[i__2].r = akk; ap[i__2].i = 0.; // , expr subst if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1); d__1 = akk * -.5; ct.r = d__1; ct.i = 0.; // , expr subst i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; z__1.r = -1.; z__1.i = -0.; // , expr subst zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]); i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U**H */ /* K1 and KK are the indices of A(1,k) and A(k,k) */ kk = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1 = kk + 1; kk += k; /* Update the upper triangle of A(1:k,1:k) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; i__2 = k - 1; ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1); d__1 = akk * .5; ct.r = d__1; ct.i = 0.; // , expr subst i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]); i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zdscal_(&i__2, &bkk, &ap[k1], &c__1); i__2 = kk; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); ap[i__2].r = d__1; ap[i__2].i = 0.; // , expr subst /* L30: */ } } else { /* Compute L**H *A*L */ /* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1j1 = jj + *n - j + 1; /* Compute the j-th column of the lower triangle of A */ i__2 = jj; ajj = ap[i__2].r; i__2 = jj; bjj = bp[i__2].r; i__2 = jj; d__1 = ajj * bjj; i__3 = *n - j; zdotc_f2c_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); z__1.r = d__1 + z__2.r; z__1.i = z__2.i; // , expr subst ap[i__2].r = z__1.r; ap[i__2].i = z__1.i; // , expr subst i__2 = *n - j; zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1); i__2 = *n - j + 1; ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of ZHPGST */ }