int f2c_zher2(char* uplo, integer* N, doublecomplex* alpha, doublecomplex* X, integer* incX, doublecomplex* Y, integer* incY, doublecomplex* A, integer* lda) { zher2_(uplo, N, alpha, X, incX, Y, incY, A, lda); return 0; }
void cblas_zher2(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 *A, const integer lda) { char UL; #ifdef F77_CHAR F77_CHAR F77_UL; #else #define F77_UL &UL #endif #define F77_N N #define F77_lda lda #define F77_incX incx #define F77_incY incy integer n, i, j, tincx, tincy, incx=incX, incy=incY; double *x=(double *)X, *xx=(double *)X, *y=(double *)Y, *yy=(double *)Y, *tx, *ty, *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_zher2", "Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif zher2_(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (order == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_zher2", "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)); tx = x; ty = y; if( incX > 0 ) { i = incX << 1 ; tincx = 2; stx= x+n; } else { i = incX *(-2); tincx = -2; stx = x-2; x +=(n-2); } if( incY > 0 ) { j = incY << 1; tincy = 2; sty= y+n; } else { j = incY *(-2); tincy = -2; sty = y-2; y +=(n-2); } do { *x = *xx; x[1] = -xx[1]; x += tincx ; xx += i; } while (x != stx); do { *y = *yy; y[1] = -yy[1]; y += tincy ; yy += j; } while (y != sty); x=tx; y=ty; incx = 1; incy = 1; } else { x = (double *) X; y = (double *) Y; } zher2_(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, A, &F77_lda); } else { cblas_xerbla(1, "cblas_zher2", "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; }
void zher2(char uplo, int n, doublecomplex *alpha, doublecomplex *x, int incx, doublecomplex *y, int incy, doublecomplex *a, int lda) { zher2_( &uplo, &n, alpha, x, &incx, y, &incy, a, &lda); }
/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d, doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublereal d__1; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ double z_abs(doublecomplex *); void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg( doublecomplex *, doublecomplex *); /* Local variables */ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer i, j; static doublecomplex alpha; extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zscal_(integer *, doublecomplex *, doublecomplex *, integer *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zhemv_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal dznrm2_(integer *, doublecomplex *, integer *); static doublecomplex wa, wb; static doublereal wn; extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_( integer *, integer *, integer *, doublecomplex *); static doublecomplex tau; /* -- LAPACK auxiliary test routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZLAGHE generates a complex hermitian matrix A, by pre- and post- multiplying a real diagonal matrix D with a random unitary matrix: A = U*D*U'. The semi-bandwidth may then be reduced to k by additional unitary transformations. Arguments ========= N (input) INTEGER The order of the matrix A. N >= 0. K (input) INTEGER The number of nonzero subdiagonals within the band of A. 0 <= K <= N-1. D (input) DOUBLE PRECISION array, dimension (N) The diagonal elements of the diagonal matrix D. A (output) COMPLEX*16 array, dimension (LDA,N) The generated n by n hermitian matrix A (the full matrix is stored). LDA (input) INTEGER The leading dimension of the array A. LDA >= N. ISEED (input/output) INTEGER array, dimension (4) On entry, the seed of the random number generator; the array elements must be between 0 and 4095, and ISEED(4) must be odd. On exit, the seed is updated. WORK (workspace) COMPLEX*16 array, dimension (2*N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ --d; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --iseed; --work; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*k < 0 || *k > *n - 1) { *info = -2; } else if (*lda < max(1,*n)) { *info = -5; } if (*info < 0) { i__1 = -(*info); xerbla_("ZLAGHE", &i__1); return 0; } /* initialize lower triangle of A to diagonal matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i = j + 1; i <= i__2; ++i) { i__3 = i + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ } /* L20: */ } i__1 = *n; for (i = 1; i <= i__1; ++i) { i__2 = i + i * a_dim1; i__3 = i; a[i__2].r = d[i__3], a[i__2].i = 0.; /* L30: */ } /* Generate lower triangle of hermitian matrix */ for (i = *n - 1; i >= 1; --i) { /* generate random reflection */ i__1 = *n - i + 1; zlarnv_(&c__3, &iseed[1], &i__1, &work[1]); i__1 = *n - i + 1; wn = dznrm2_(&i__1, &work[1], &c__1); d__1 = wn / z_abs(&work[1]); z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i; wa.r = z__1.r, wa.i = z__1.i; if (wn == 0.) { tau.r = 0., tau.i = 0.; } else { z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i; wb.r = z__1.r, wb.i = z__1.i; i__1 = *n - i; z_div(&z__1, &c_b2, &wb); zscal_(&i__1, &z__1, &work[2], &c__1); work[1].r = 1., work[1].i = 0.; z_div(&z__1, &wb, &wa); d__1 = z__1.r; tau.r = d__1, tau.i = 0.; } /* apply random reflection to A(i:n,i:n) from the left and the right compute y := tau * A * u */ i__1 = *n - i + 1; zhemv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); /* compute v := y - 1/2 * tau * ( y, u ) * u */ z__3.r = -.5, z__3.i = 0.; z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + z__3.i * tau.r; i__1 = *n - i + 1; zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[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__1 = *n - i + 1; zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); /* apply the transformation as a rank-2 update to A(i:n,i:n) */ i__1 = *n - i + 1; z__1.r = -1., z__1.i = 0.; zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, & a[i + i * a_dim1], lda); /* L40: */ } /* Reduce number of subdiagonals to K */ i__1 = *n - 1 - *k; for (i = 1; i <= i__1; ++i) { /* generate reflection to annihilate A(k+i+1:n,i) */ i__2 = *n - *k - i + 1; wn = dznrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1); d__1 = wn / z_abs(&a[*k + i + i * a_dim1]); i__2 = *k + i + i * a_dim1; z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; wa.r = z__1.r, wa.i = z__1.i; if (wn == 0.) { tau.r = 0., tau.i = 0.; } else { i__2 = *k + i + i * a_dim1; z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; wb.r = z__1.r, wb.i = z__1.i; i__2 = *n - *k - i; z_div(&z__1, &c_b2, &wb); zscal_(&i__2, &z__1, &a[*k + i + 1 + i * a_dim1], &c__1); i__2 = *k + i + i * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; z_div(&z__1, &wb, &wa); d__1 = z__1.r; tau.r = d__1, tau.i = 0.; } /* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ i__2 = *n - *k - i + 1; i__3 = *k - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1) * a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[ 1], &c__1); i__2 = *n - *k - i + 1; i__3 = *k - 1; z__1.r = -tau.r, z__1.i = -tau.i; zgerc_(&i__2, &i__3, &z__1, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1, &a[*k + i + (i + 1) * a_dim1], lda); /* apply reflection to A(k+i:n,k+i:n) from the left and the rig ht compute y := tau * A * u */ i__2 = *n - *k - i + 1; zhemv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[* k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1); /* compute v := y - 1/2 * tau * ( y, u ) * u */ z__3.r = -.5, z__3.i = 0.; z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + z__3.i * tau.r; i__2 = *n - *k - i + 1; zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i + i * a_dim1], &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 - *k - i + 1; zaxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1) ; /* apply hermitian rank-2 update to A(k+i:n,k+i:n) */ i__2 = *n - *k - i + 1; z__1.r = -1., z__1.i = 0.; zher2_("Lower", &i__2, &z__1, &a[*k + i + i * a_dim1], &c__1, &work[1] , &c__1, &a[*k + i + (*k + i) * a_dim1], lda); i__2 = *k + i + i * a_dim1; z__1.r = -wa.r, z__1.i = -wa.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = *n; for (j = *k + i + 1; j <= i__2; ++j) { i__3 = j + i * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L50: */ } /* L60: */ } /* Store full hermitian matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i = j + 1; i <= i__2; ++i) { i__3 = j + i * a_dim1; d_cnjg(&z__1, &a[i + j * a_dim1]); a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L70: */ } /* L80: */ } return 0; /* End of ZLAGHE */ } /* zlaghe_ */
/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d__, doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublereal d__1; doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ integer i__, j; doublecomplex wa, wb; doublereal wn; doublecomplex tau; doublecomplex alpha; /* -- LAPACK auxiliary test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLAGHE generates a complex hermitian matrix A, by pre- and post- */ /* multiplying a real diagonal matrix D with a random unitary matrix: */ /* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */ /* unitary transformations. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* K (input) INTEGER */ /* The number of nonzero subdiagonals within the band of A. */ /* 0 <= K <= N-1. */ /* D (input) DOUBLE PRECISION array, dimension (N) */ /* The diagonal elements of the diagonal matrix D. */ /* A (output) COMPLEX*16 array, dimension (LDA,N) */ /* The generated n by n hermitian matrix A (the full matrix is */ /* stored). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= N. */ /* ISEED (input/output) INTEGER array, dimension (4) */ /* On entry, the seed of the random number generator; the array */ /* elements must be between 0 and 4095, and ISEED(4) must be */ /* odd. */ /* On exit, the seed is updated. */ /* WORK (workspace) COMPLEX*16 array, dimension (2*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ --d__; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --iseed; --work; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*k < 0 || *k > *n - 1) { *info = -2; } else if (*lda < max(1,*n)) { *info = -5; } if (*info < 0) { i__1 = -(*info); xerbla_("ZLAGHE", &i__1); return 0; } /* initialize lower triangle of A to diagonal matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ } /* L20: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * a_dim1; i__3 = i__; a[i__2].r = d__[i__3], a[i__2].i = 0.; /* L30: */ } /* Generate lower triangle of hermitian matrix */ for (i__ = *n - 1; i__ >= 1; --i__) { /* generate random reflection */ i__1 = *n - i__ + 1; zlarnv_(&c__3, &iseed[1], &i__1, &work[1]); i__1 = *n - i__ + 1; wn = dznrm2_(&i__1, &work[1], &c__1); d__1 = wn / z_abs(&work[1]); z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i; wa.r = z__1.r, wa.i = z__1.i; if (wn == 0.) { tau.r = 0., tau.i = 0.; } else { z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i; wb.r = z__1.r, wb.i = z__1.i; i__1 = *n - i__; z_div(&z__1, &c_b2, &wb); zscal_(&i__1, &z__1, &work[2], &c__1); work[1].r = 1., work[1].i = 0.; z_div(&z__1, &wb, &wa); d__1 = z__1.r; tau.r = d__1, tau.i = 0.; } /* apply random reflection to A(i:n,i:n) from the left */ /* and the right */ /* compute y := tau * A * u */ i__1 = *n - i__ + 1; zhemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & c__1, &c_b1, &work[*n + 1], &c__1); /* compute v := y - 1/2 * tau * ( y, u ) * u */ z__3.r = -.5, z__3.i = -0.; z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + z__3.i * tau.r; i__1 = *n - i__ + 1; zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[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__1 = *n - i__ + 1; zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); /* apply the transformation as a rank-2 update to A(i:n,i:n) */ i__1 = *n - i__ + 1; z__1.r = -1., z__1.i = -0.; zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, & a[i__ + i__ * a_dim1], lda); /* L40: */ } /* Reduce number of subdiagonals to K */ i__1 = *n - 1 - *k; for (i__ = 1; i__ <= i__1; ++i__) { /* generate reflection to annihilate A(k+i+1:n,i) */ i__2 = *n - *k - i__ + 1; wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]); i__2 = *k + i__ + i__ * a_dim1; z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; wa.r = z__1.r, wa.i = z__1.i; if (wn == 0.) { tau.r = 0., tau.i = 0.; } else { i__2 = *k + i__ + i__ * a_dim1; z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; wb.r = z__1.r, wb.i = z__1.i; i__2 = *n - *k - i__; z_div(&z__1, &c_b2, &wb); zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); i__2 = *k + i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; z_div(&z__1, &wb, &wa); d__1 = z__1.r; tau.r = d__1, tau.i = 0.; } /* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ i__2 = *n - *k - i__ + 1; i__3 = *k - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, & c_b1, &work[1], &c__1); i__2 = *n - *k - i__ + 1; i__3 = *k - 1; z__1.r = -tau.r, z__1.i = -tau.i; zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); /* apply reflection to A(k+i:n,k+i:n) from the left and the right */ /* compute y := tau * A * u */ i__2 = *n - *k - i__ + 1; zhemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1); /* compute v := y - 1/2 * tau * ( y, u ) * u */ z__3.r = -.5, z__3.i = -0.; z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + z__3.i * tau.r; i__2 = *n - *k - i__ + 1; zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], & 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 - *k - i__ + 1; zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & c__1); /* apply hermitian rank-2 update to A(k+i:n,k+i:n) */ i__2 = *n - *k - i__ + 1; z__1.r = -1., z__1.i = -0.; zher2_("Lower", &i__2, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, & work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda); i__2 = *k + i__ + i__ * a_dim1; z__1.r = -wa.r, z__1.i = -wa.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = *n; for (j = *k + i__ + 1; j <= i__2; ++j) { i__3 = j + i__ * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L50: */ } /* L60: */ } /* Store full hermitian matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = j + i__ * a_dim1; d_cnjg(&z__1, &a[i__ + j * a_dim1]); a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L70: */ } /* L80: */ } return 0; /* End of ZLAGHE */ } /* zlaghe_ */
/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; doublereal d__1, d__2; doublecomplex z__1; /* Local variables */ integer k; doublecomplex ct; doublereal akk, bkk; logical upper; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* ZHEGS2 reduces a complex Hermitian-definite generalized */ /* eigenproblem to standard form. */ /* If ITYPE = 1, the problem is A*x = lambda*B*x, */ /* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */ /* 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` or L'*A*L. */ /* B must have been previously factorized as U'*U or L*L' by ZPOTRF. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */ /* = 2 or 3: compute U*A*U' or L'*A*L. */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* Hermitian matrix A is stored, and how B has been factorized. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ /* n by n upper triangular part of A contains the upper */ /* triangular part of the matrix A, and the strictly lower */ /* triangular part of A is not referenced. If UPLO = 'L', the */ /* leading n by n lower triangular part of A contains the lower */ /* triangular part of the matrix A, and the strictly upper */ /* triangular part of A is not referenced. */ /* On exit, if INFO = 0, the transformed matrix, stored in the */ /* same format as A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* B (input) COMPLEX*16 array, dimension (LDB,N) */ /* The triangular factor from the Cholesky factorization of B, */ /* as returned by ZPOTRF. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* 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; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHEGS2", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the upper triangle of A(k:n,k:n) */ i__2 = k + k * a_dim1; akk = a[i__2].r; i__2 = k + k * b_dim1; bkk = b[i__2].r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = k + k * a_dim1; a[i__2].r = akk, a[i__2].i = 0.; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda); d__1 = akk * -.5; ct.r = d__1, ct.i = 0.; i__2 = *n - k; zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda); i__2 = *n - k; zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb); i__2 = *n - k; zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( k + 1) * a_dim1], lda); i__2 = *n - k; z__1.r = -1., z__1.i = -0.; zher2_(uplo, &i__2, &z__1, &a[k + (k + 1) * a_dim1], lda, &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) * a_dim1], lda); i__2 = *n - k; zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( k + 1) * a_dim1], lda); i__2 = *n - k; zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb); i__2 = *n - k; ztrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[ k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], lda); i__2 = *n - k; zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda); } } } else { /* Compute inv(L)*A*inv(L') */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the lower triangle of A(k:n,k:n) */ i__2 = k + k * a_dim1; akk = a[i__2].r; i__2 = k + k * b_dim1; bkk = b[i__2].r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = k + k * a_dim1; a[i__2].r = akk, a[i__2].i = 0.; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1); d__1 = akk * -.5; ct.r = d__1, ct.i = 0.; i__2 = *n - k; zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + k * a_dim1], &c__1); i__2 = *n - k; z__1.r = -1., z__1.i = -0.; zher2_(uplo, &i__2, &z__1, &a[k + 1 + k * a_dim1], &c__1, &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) * a_dim1], lda); i__2 = *n - k; zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + k * a_dim1], &c__1); i__2 = *n - k; ztrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1 + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1); } } } } else { if (upper) { /* Compute U*A*U' */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the upper triangle of A(1:k,1:k) */ i__2 = k + k * a_dim1; akk = a[i__2].r; i__2 = k + k * b_dim1; bkk = b[i__2].r; i__2 = k - 1; ztrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset], ldb, &a[k * a_dim1 + 1], &c__1); d__1 = akk * .5; ct.r = d__1, ct.i = 0.; i__2 = k - 1; zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); i__2 = k - 1; zher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k * b_dim1 + 1], &c__1, &a[a_offset], lda); i__2 = k - 1; zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); i__2 = k - 1; zdscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1); i__2 = k + k * a_dim1; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); a[i__2].r = d__1, a[i__2].i = 0.; } } else { /* Compute L'*A*L */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the lower triangle of A(1:k,1:k) */ i__2 = k + k * a_dim1; akk = a[i__2].r; i__2 = k + k * b_dim1; bkk = b[i__2].r; i__2 = k - 1; zlacgv_(&i__2, &a[k + a_dim1], lda); i__2 = k - 1; ztrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[ b_offset], ldb, &a[k + a_dim1], lda); d__1 = akk * .5; ct.r = d__1, ct.i = 0.; i__2 = k - 1; zlacgv_(&i__2, &b[k + b_dim1], ldb); i__2 = k - 1; zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); i__2 = k - 1; zher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1] , ldb, &a[a_offset], lda); i__2 = k - 1; zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); i__2 = k - 1; zlacgv_(&i__2, &b[k + b_dim1], ldb); i__2 = k - 1; zdscal_(&i__2, &bkk, &a[k + a_dim1], lda); i__2 = k - 1; zlacgv_(&i__2, &a[k + a_dim1], lda); i__2 = k + k * a_dim1; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); a[i__2].r = d__1, a[i__2].i = 0.; } } } return 0; /* End of ZHEGS2 */ } /* zhegs2_ */
/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZHEGS2 reduces a complex Hermitian-definite generalized eigenproblem to standard form. If ITYPE = 1, the problem is A*x = lambda*B*x, and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') 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` or L'*A*L. B must have been previously factorized as U'*U or L*L' by ZPOTRF. Arguments ========= ITYPE (input) INTEGER = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); = 2 or 3: compute U*A*U' or L'*A*L. UPLO (input) CHARACTER Specifies whether the upper or lower triangular part of the Hermitian matrix A is stored, and how B has been factorized. = 'U': Upper triangular = 'L': Lower triangular N (input) INTEGER The order of the matrices A and B. N >= 0. A (input/output) COMPLEX*16 array, dimension (LDA,N) On entry, the Hermitian matrix A. If UPLO = 'U', the leading n by n upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If UPLO = 'L', the leading n by n lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if INFO = 0, the transformed matrix, stored in the same format as A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input) COMPLEX*16 array, dimension (LDB,N) The triangular factor from the Cholesky factorization of B, as returned by ZPOTRF. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; doublereal d__1, d__2; doublecomplex z__1; /* Local variables */ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer k; extern logical lsame_(char *, char *); static logical upper; extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztrmv_( char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztrsv_(char * , char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static doublecomplex ct; extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *), zlacgv_( integer *, doublecomplex *, integer *); static doublereal akk, bkk; #define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)] #define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)] *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; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHEGS2", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ i__1 = *n; for (k = 1; k <= *n; ++k) { /* Update the upper triangle of A(k:n,k:n) */ i__2 = k + k * a_dim1; akk = A(k,k).r; i__2 = k + k * b_dim1; bkk = B(k,k).r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = k + k * a_dim1; A(k,k).r = akk, A(k,k).i = 0.; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &A(k,k+1), lda); d__1 = akk * -.5; ct.r = d__1, ct.i = 0.; i__2 = *n - k; zlacgv_(&i__2, &A(k,k+1), lda); i__2 = *n - k; zlacgv_(&i__2, &B(k,k+1), ldb); i__2 = *n - k; zaxpy_(&i__2, &ct, &B(k,k+1), ldb, &A(k,k+1), lda); i__2 = *n - k; z__1.r = -1., z__1.i = 0.; zher2_(uplo, &i__2, &z__1, &A(k,k+1), lda, &B(k,k+1), ldb, &A(k+1,k+1), lda); i__2 = *n - k; zaxpy_(&i__2, &ct, &B(k,k+1), ldb, &A(k,k+1), lda); i__2 = *n - k; zlacgv_(&i__2, &B(k,k+1), ldb); i__2 = *n - k; ztrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &B(k+1,k+1), ldb, &A(k,k+1), lda); i__2 = *n - k; zlacgv_(&i__2, &A(k,k+1), lda); } /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ i__1 = *n; for (k = 1; k <= *n; ++k) { /* Update the lower triangle of A(k:n,k:n) */ i__2 = k + k * a_dim1; akk = A(k,k).r; i__2 = k + k * b_dim1; bkk = B(k,k).r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = k + k * a_dim1; A(k,k).r = akk, A(k,k).i = 0.; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &A(k+1,k), &c__1); d__1 = akk * -.5; ct.r = d__1, ct.i = 0.; i__2 = *n - k; zaxpy_(&i__2, &ct, &B(k+1,k), &c__1, &A(k+1,k), &c__1); i__2 = *n - k; z__1.r = -1., z__1.i = 0.; zher2_(uplo, &i__2, &z__1, &A(k+1,k), &c__1, &B(k+1,k), &c__1, &A(k+1,k+1), lda); i__2 = *n - k; zaxpy_(&i__2, &ct, &B(k+1,k), &c__1, &A(k+1,k), &c__1); i__2 = *n - k; ztrsv_(uplo, "No transpose", "Non-unit", &i__2, &B(k+1,k+1), ldb, &A(k+1,k), &c__1); } /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ i__1 = *n; for (k = 1; k <= *n; ++k) { /* Update the upper triangle of A(1:k,1:k) */ i__2 = k + k * a_dim1; akk = A(k,k).r; i__2 = k + k * b_dim1; bkk = B(k,k).r; i__2 = k - 1; ztrmv_(uplo, "No transpose", "Non-unit", &i__2, &B(1,1), ldb, &A(1,k), &c__1); d__1 = akk * .5; ct.r = d__1, ct.i = 0.; i__2 = k - 1; zaxpy_(&i__2, &ct, &B(1,k), &c__1, &A(1,k), &c__1); i__2 = k - 1; zher2_(uplo, &i__2, &c_b1, &A(1,k), &c__1, &B(1,k), &c__1, &A(1,1), lda); i__2 = k - 1; zaxpy_(&i__2, &ct, &B(1,k), &c__1, &A(1,k), &c__1); i__2 = k - 1; zdscal_(&i__2, &bkk, &A(1,k), &c__1); i__2 = k + k * a_dim1; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); A(k,k).r = d__1, A(k,k).i = 0.; /* L30: */ } } else { /* Compute L'*A*L */ i__1 = *n; for (k = 1; k <= *n; ++k) { /* Update the lower triangle of A(1:k,1:k) */ i__2 = k + k * a_dim1; akk = A(k,k).r; i__2 = k + k * b_dim1; bkk = B(k,k).r; i__2 = k - 1; zlacgv_(&i__2, &A(k,1), lda); i__2 = k - 1; ztrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &B(1,1), ldb, &A(k,1), lda); d__1 = akk * .5; ct.r = d__1, ct.i = 0.; i__2 = k - 1; zlacgv_(&i__2, &B(k,1), ldb); i__2 = k - 1; zaxpy_(&i__2, &ct, &B(k,1), ldb, &A(k,1), lda); i__2 = k - 1; zher2_(uplo, &i__2, &c_b1, &A(k,1), lda, &B(k,1) , ldb, &A(1,1), lda); i__2 = k - 1; zaxpy_(&i__2, &ct, &B(k,1), ldb, &A(k,1), lda); i__2 = k - 1; zlacgv_(&i__2, &B(k,1), ldb); i__2 = k - 1; zdscal_(&i__2, &bkk, &A(k,1), lda); i__2 = k - 1; zlacgv_(&i__2, &A(k,1), lda); i__2 = k + k * a_dim1; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); A(k,k).r = d__1, A(k,k).i = 0.; /* L40: */ } } } return 0; /* End of ZHEGS2 */ } /* zhegs2_ */
/* Subroutine */ int zhet21_(integer *itype, char *uplo, integer *n, integer * kband, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e, doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *work, doublereal *rwork, doublereal *result) { /* System generated locals */ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_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 */ integer j, jr; doublereal ulp; integer jcol; doublereal unfl; extern /* Subroutine */ int zher_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *); integer jrow; extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern logical lsame_(char *, char *); integer iinfo; doublereal anorm; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); char cuplo[1]; doublecomplex vsave; logical lower; doublereal wnorm; extern /* Subroutine */ int zunm2l_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal dlamch_(char *); extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *), zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *); extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlarfy_( char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, 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 */ /* ======= */ /* ZHET21 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 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 ) */ /* For ITYPE > 1, the transformation U is expressed as a product */ /* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)* and each */ /* vector v(j) has its first j elements 0 and the remaining n-j elements */ /* stored in V(j+1:n,j). */ /* 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, ZHET21 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. */ /* A (input) COMPLEX*16 array, dimension (LDA, N) */ /* The original (unfactored) matrix. It is assumed to be */ /* hermitian, and only the upper (UPLO='U') or only the lower */ /* (UPLO='L') will be referenced. */ /* LDA (input) INTEGER */ /* The leading dimension of A. It must be at least 1 */ /* and at least N. */ /* D (input) DOUBLE PRECISION array, dimension (N) */ /* The diagonal of the (symmetric tri-) diagonal matrix. */ /* E (input) DOUBLE PRECISION array, dimension (N-1) */ /* 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. */ /* V (input) COMPLEX*16 array, dimension (LDV, N) */ /* If ITYPE=2 or 3, the columns of this array contain the */ /* Householder vectors used to describe the unitary matrix */ /* in the decomposition. If UPLO='L', then the vectors are in */ /* the lower triangle, if UPLO='U', then in the upper */ /* triangle. */ /* *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. */ /* LDV (input) INTEGER */ /* The leading dimension of V. LDV must be at least N and */ /* at least 1. */ /* 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 (2*N**2) */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* 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. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --d__; --e; u_dim1 = *ldu; u_offset = 1 + u_dim1; u -= u_offset; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --tau; --work; --rwork; --result; /* Function Body */ result[1] = 0.; if (*itype == 1) { result[2] = 0.; } if (*n <= 0) { return 0; } 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 = zlanhe_("1", cuplo, n, &a[a_offset], lda, &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); zlacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n); i__1 = *n; for (j = 1; j <= i__1; ++j) { d__1 = -d__[j]; zher_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n); /* 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; zher2_(cuplo, n, &z__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1) * u_dim1 + 1], &c__1, &work[1], n); /* L20: */ } } wnorm = zlanhe_("1", cuplo, n, &work[1], n, &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) { /* Computing 2nd power */ i__2 = *n; i__1 = i__2 * i__2; i__3 = *n; work[i__1].r = d__[i__3], work[i__1].i = 0.; for (j = *n - 1; j >= 1; --j) { if (*kband == 1) { i__1 = (*n + 1) * (j - 1) + 2; 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 = (j - 1) * *n + 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 = jr + j * v_dim1; z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5] .r; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L30: */ } } i__1 = j + 1 + j * v_dim1; vsave.r = v[i__1].r, vsave.i = v[i__1].i; i__1 = j + 1 + j * v_dim1; v[i__1].r = 1., v[i__1].i = 0.; i__1 = *n - j; /* Computing 2nd power */ i__2 = *n; zlarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], & work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]); i__1 = j + 1 + j * v_dim1; v[i__1].r = vsave.r, v[i__1].i = vsave.i; i__1 = (*n + 1) * (j - 1) + 1; 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) { if (*kband == 1) { i__2 = (*n + 1) * 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 = j * *n + 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 = jr + (j + 1) * v_dim1; z__1.r = z__2.r * v[i__6].r - z__2.i * v[i__6].i, z__1.i = z__2.r * v[i__6].i + z__2.i * v[i__6] .r; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L50: */ } } i__2 = j + (j + 1) * v_dim1; vsave.r = v[i__2].r, vsave.i = v[i__2].i; i__2 = j + (j + 1) * v_dim1; v[i__2].r = 1., v[i__2].i = 0.; /* Computing 2nd power */ i__2 = *n; zlarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], & work[1], n, &work[i__2 * i__2 + 1]); i__2 = j + (j + 1) * v_dim1; v[i__2].r = vsave.r, v[i__2].i = vsave.i; i__2 = (*n + 1) * j + 1; i__3 = j + 1; work[i__2].r = d__[i__3], work[i__2].i = 0.; /* L60: */ } } i__1 = *n; for (jcol = 1; jcol <= i__1; ++jcol) { if (lower) { i__2 = *n; for (jrow = jcol; jrow <= i__2; ++jrow) { i__3 = jrow + *n * (jcol - 1); i__4 = jrow + *n * (jcol - 1); i__5 = jrow + jcol * a_dim1; z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i - a[i__5].i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L70: */ } } else { i__2 = jcol; for (jrow = 1; jrow <= i__2; ++jrow) { i__3 = jrow + *n * (jcol - 1); i__4 = jrow + *n * (jcol - 1); i__5 = jrow + jcol * a_dim1; z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i - a[i__5].i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L80: */ } } /* L90: */ } wnorm = zlanhe_("1", cuplo, n, &work[1], n, &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); if (lower) { i__1 = *n - 1; i__2 = *n - 1; /* Computing 2nd power */ i__3 = *n; zunm2r_("R", "C", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], & work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo); } else { i__1 = *n - 1; i__2 = *n - 1; /* Computing 2nd power */ i__3 = *n; zunm2l_("R", "C", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, & tau[1], &work[1], n, &work[i__3 * i__3 + 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; /* L100: */ } 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; /* L110: */ } /* 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 ZHET21 */ } /* zhet21_ */
int zhetd2_(char *uplo, int *n, doublecomplex *a, int *lda, double *d__, double *e, doublecomplex *tau, int *info) { /* System generated locals */ int a_dim1, a_offset, i__1, i__2, i__3; double d__1; doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ int i__; doublecomplex taui; extern int zher2_(char *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, doublecomplex *, int *); doublecomplex alpha; extern int lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, int *, doublecomplex *, int *, doublecomplex *, int *); extern int zhemv_(char *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *); int upper; extern int zaxpy_(int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *), xerbla_( char *, int *), zlarfg_(int *, doublecomplex *, doublecomplex *, int *, doublecomplex *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZHETD2 reduces a complex Hermitian matrix A to float symmetric */ /* tridiagonal form T by a unitary similarity transformation: */ /* Q' * A * Q = T. */ /* 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 order of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ /* n-by-n upper triangular part of A contains the upper */ /* triangular part of the matrix A, and the strictly lower */ /* triangular part of A is not referenced. If UPLO = 'L', the */ /* leading n-by-n lower triangular part of A contains the lower */ /* triangular part of the matrix A, and the strictly upper */ /* triangular part of A is not referenced. */ /* 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. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= MAX(1,N). */ /* 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 */ /* A(1:i-1,i+1), and tau 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 A(i+2:n,i), */ /* and tau in TAU(i). */ /* The contents of A on exit are illustrated by the following examples */ /* with n = 5: */ /* if UPLO = 'U': if UPLO = 'L': */ /* ( d e v2 v3 v4 ) ( d ) */ /* ( d e v3 v4 ) ( e d ) */ /* ( d e v4 ) ( v1 e d ) */ /* ( d e ) ( v1 v2 e d ) */ /* ( d ) ( v1 v2 v3 e d ) */ /* where d and e denote diagonal and off-diagonal elements of T, and vi */ /* denotes an element of the vector defining H(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --d__; --e; --tau; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < MAX(1,*n)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHETD2", &i__1); return 0; } /* Quick return if possible */ if (*n <= 0) { return 0; } if (upper) { /* Reduce the upper triangle of A */ i__1 = *n + *n * a_dim1; i__2 = *n + *n * a_dim1; d__1 = a[i__2].r; a[i__1].r = d__1, a[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 = i__ + (i__ + 1) * a_dim1; alpha.r = a[i__1].r, alpha.i = a[i__1].i; zlarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &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 = i__ + (i__ + 1) * a_dim1; a[i__1].r = 1., a[i__1].i = 0.; /* Compute x := tau * A * v storing x in TAU(1:i) */ zhemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1); /* Compute w := x - 1/2 * tau * (x'*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, &a[(i__ + 1) * a_dim1 + 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; zaxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &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.; zher2_(uplo, &i__, &z__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, & tau[1], &c__1, &a[a_offset], lda); } else { i__1 = i__ + i__ * a_dim1; i__2 = i__ + i__ * a_dim1; d__1 = a[i__2].r; a[i__1].r = d__1, a[i__1].i = 0.; } i__1 = i__ + (i__ + 1) * a_dim1; i__2 = i__; a[i__1].r = e[i__2], a[i__1].i = 0.; i__1 = i__ + 1; i__2 = i__ + 1 + (i__ + 1) * a_dim1; d__[i__1] = a[i__2].r; i__1 = i__; tau[i__1].r = taui.r, tau[i__1].i = taui.i; /* L10: */ } i__1 = a_dim1 + 1; d__[1] = a[i__1].r; } else { /* Reduce the lower triangle of A */ i__1 = a_dim1 + 1; i__2 = a_dim1 + 1; d__1 = a[i__2].r; a[i__1].r = d__1, a[i__1].i = 0.; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) = I - tau * v * v' */ /* to annihilate A(i+2:n,i) */ i__2 = i__ + 1 + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__; /* Computing MIN */ i__3 = i__ + 2; zlarfg_(&i__2, &alpha, &a[MIN(i__3, *n)+ i__ * a_dim1], &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 = i__ + 1 + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Compute x := tau * A * v storing y in TAU(i:n-1) */ i__2 = *n - i__; zhemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[ i__], &c__1); /* Compute w := x - 1/2 * tau * (x'*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, &a[i__ + 1 + i__ * a_dim1], &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, &a[i__ + 1 + i__ * a_dim1], &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.; zher2_(uplo, &i__2, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda); } else { i__2 = i__ + 1 + (i__ + 1) * a_dim1; i__3 = i__ + 1 + (i__ + 1) * a_dim1; d__1 = a[i__3].r; a[i__2].r = d__1, a[i__2].i = 0.; } i__2 = i__ + 1 + i__ * a_dim1; i__3 = i__; a[i__2].r = e[i__3], a[i__2].i = 0.; i__2 = i__; i__3 = i__ + i__ * a_dim1; d__[i__2] = a[i__3].r; i__2 = i__; tau[i__2].r = taui.r, tau[i__2].i = taui.i; /* L20: */ } i__1 = *n; i__2 = *n + *n * a_dim1; d__[i__1] = a[i__2].r; } return 0; /* End of ZHETD2 */ } /* zhetd2_ */