コード例 #1
0
ファイル: fblaswr.c プロジェクト: CIBC-Internal/clapack
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;
}
コード例 #2
0
ファイル: zhptri.c プロジェクト: flame/libflame
/* 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 */
}
コード例 #3
0
ファイル: zpprfs.c プロジェクト: dacap/loseface
/* 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_ */
コード例 #4
0
ファイル: zhptrd.c プロジェクト: flame/libflame
/* 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 */
}
コード例 #5
0
/* 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_ */
コード例 #6
0
ファイル: blas-lapack.c プロジェクト: BenjaminCoquelle/clBLAS
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 );
}
コード例 #7
0
ファイル: zhpgst.c プロジェクト: 0u812/roadrunner-backup
/* 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_ */
コード例 #8
0
/* 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_ */
コード例 #9
0
/* 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_ */
コード例 #10
0
ファイル: zhprfs.c プロジェクト: flame/libflame
/* 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 */
}
コード例 #11
0
ファイル: zppt02.c プロジェクト: 3deggi/levmar-ndk
/* 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_ */
コード例 #12
0
ファイル: zhpt21.c プロジェクト: zangel/uquad
/* 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_ */
コード例 #13
0
ファイル: zppt03.c プロジェクト: kstraube/hysim
/* 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_ */
コード例 #14
0
ファイル: zhpgst.c プロジェクト: flame/libflame
/* 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 */
}