예제 #1
0
int
f2c_zhpr2(char* uplo, integer* N,
          doublecomplex* alpha,
          doublecomplex* X, integer* incX,
          doublecomplex* Y, integer* incY,
          doublecomplex* Ap)
{
    zhpr2_(uplo, N, alpha,
           X, incX, Y, incY, Ap);
    return 0;
}
예제 #2
0
void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
                      const integer N,const void *alpha, const void *X, 
                      const integer incX,const void *Y, const integer incY, void *Ap)

{
   char UL;
#ifdef F77_CHAR
   F77_CHAR F77_UL;
#else
   #define F77_UL &UL
#endif

   #define F77_N N
   #define F77_incX incx
   #define F77_incY incy
   integer n, i, j, incx=incX, incy=incY;
   double *x=(double *)X, *xx=(double *)X, *y=(double *)Y,
         *yy=(double *)Y, *stx, *sty;

   extern integer CBLAS_CallFromC;
   extern integer RowMajorStrg;
   RowMajorStrg = 0;
 
   CBLAS_CallFromC = 1;
   if (order == CblasColMajor)
   {
      if (Uplo == CblasLower) UL = 'L';
      else if (Uplo == CblasUpper) UL = 'U';
      else 
      {
         cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo );
         CBLAS_CallFromC = 0;
         RowMajorStrg = 0;
         return;
      }
      #ifdef F77_CHAR
         F77_UL = C2F_CHAR(&UL);
      #endif

      zhpr2_(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap);

   }  else if (order == CblasRowMajor)
   {
      RowMajorStrg = 1;
      if (Uplo == CblasUpper) UL = 'L';
      else if (Uplo == CblasLower) UL = 'U';
      else 
      {
         cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo);
         CBLAS_CallFromC = 0;
         RowMajorStrg = 0;
         return;
      }
      #ifdef F77_CHAR
         F77_UL = C2F_CHAR(&UL);
      #endif
      if (N > 0)
      {
         n = N << 1;
         x = malloc(n*sizeof(double));
         y = malloc(n*sizeof(double));         
         stx = x + n;
         sty = y + n;
         if( incX > 0 )
            i = incX << 1;
         else
            i = incX *(-2);
 
         if( incY > 0 )
            j = incY << 1;
         else
            j = incY *(-2);
         do
         {
            *x = *xx;
            x[1] = -xx[1];
            x += 2;
            xx += i;
         } while (x != stx);
         do
         {
            *y = *yy;
            y[1] = -yy[1];
            y += 2;
            yy += j;
         }
         while (y != sty);
         x -= n;
         y -= n;

            if(incX > 0 )
               incx = 1;
            else
               incx = -1;
 
            if(incY > 0 )
               incy = 1;
            else
               incy = -1;

      }  else 
      {
         x = (double *) X;
         y = (void  *) Y;
      }
      zhpr2_(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap);
   } 
   else 
   {
      cblas_xerbla(1, "cblas_zhpr2","Illegal Order setting, %d\n", order);
      CBLAS_CallFromC = 0;
      RowMajorStrg = 0;
      return;
   }
   if(X!=x)
      free(x);
   if(Y!=y)
      free(y);
   CBLAS_CallFromC = 0;
   RowMajorStrg = 0;
   return;
}
예제 #3
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 */
}
예제 #4
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_ */
예제 #5
0
void
zhpr2(char uplo, int n, doublecomplex *alpha, doublecomplex *x, int incx, doublecomplex *y, int incy, doublecomplex *a )
{
   zhpr2_( &uplo, &n, alpha, x, &incx, y, &incy, a );
}
예제 #6
0
/* 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_ */
예제 #7
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_ */
예제 #8
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 */
}