00001 /* zhetrd.f -- translated by f2c (version 20061008). 00002 You must link the resulting object file with libf2c: 00003 on Microsoft Windows system, link with libf2c.lib; 00004 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 00005 or, if you install libf2c.a in a standard place, with -lf2c -lm 00006 -- in that order, at the end of the command line, as in 00007 cc *.o -lf2c -lm 00008 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 00009 00010 http://www.netlib.org/f2c/libf2c.zip 00011 */ 00012 00013 #include "f2c.h" 00014 #include "blaswrap.h" 00015 00016 /* Table of constant values */ 00017 00018 static integer c__1 = 1; 00019 static integer c_n1 = -1; 00020 static integer c__3 = 3; 00021 static integer c__2 = 2; 00022 static doublereal c_b23 = 1.; 00023 00024 /* Subroutine */ int zhetrd_(char *uplo, integer *n, doublecomplex *a, 00025 integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, 00026 doublecomplex *work, integer *lwork, integer *info) 00027 { 00028 /* System generated locals */ 00029 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; 00030 doublecomplex z__1; 00031 00032 /* Local variables */ 00033 integer i__, j, nb, kk, nx, iws; 00034 extern logical lsame_(char *, char *); 00035 integer nbmin, iinfo; 00036 logical upper; 00037 extern /* Subroutine */ int zhetd2_(char *, integer *, doublecomplex *, 00038 integer *, doublereal *, doublereal *, doublecomplex *, integer *), zher2k_(char *, char *, integer *, integer *, 00039 doublecomplex *, doublecomplex *, integer *, doublecomplex *, 00040 integer *, doublereal *, doublecomplex *, integer *), xerbla_(char *, integer *); 00041 extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 00042 integer *, integer *); 00043 extern /* Subroutine */ int zlatrd_(char *, integer *, integer *, 00044 doublecomplex *, integer *, doublereal *, doublecomplex *, 00045 doublecomplex *, integer *); 00046 integer ldwork, lwkopt; 00047 logical lquery; 00048 00049 00050 /* -- LAPACK routine (version 3.2) -- */ 00051 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ 00052 /* November 2006 */ 00053 00054 /* .. Scalar Arguments .. */ 00055 /* .. */ 00056 /* .. Array Arguments .. */ 00057 /* .. */ 00058 00059 /* Purpose */ 00060 /* ======= */ 00061 00062 /* ZHETRD reduces a complex Hermitian matrix A to real symmetric */ 00063 /* tridiagonal form T by a unitary similarity transformation: */ 00064 /* Q**H * A * Q = T. */ 00065 00066 /* Arguments */ 00067 /* ========= */ 00068 00069 /* UPLO (input) CHARACTER*1 */ 00070 /* = 'U': Upper triangle of A is stored; */ 00071 /* = 'L': Lower triangle of A is stored. */ 00072 00073 /* N (input) INTEGER */ 00074 /* The order of the matrix A. N >= 0. */ 00075 00076 /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ 00077 /* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ 00078 /* N-by-N upper triangular part of A contains the upper */ 00079 /* triangular part of the matrix A, and the strictly lower */ 00080 /* triangular part of A is not referenced. If UPLO = 'L', the */ 00081 /* leading N-by-N lower triangular part of A contains the lower */ 00082 /* triangular part of the matrix A, and the strictly upper */ 00083 /* triangular part of A is not referenced. */ 00084 /* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ 00085 /* of A are overwritten by the corresponding elements of the */ 00086 /* tridiagonal matrix T, and the elements above the first */ 00087 /* superdiagonal, with the array TAU, represent the unitary */ 00088 /* matrix Q as a product of elementary reflectors; if UPLO */ 00089 /* = 'L', the diagonal and first subdiagonal of A are over- */ 00090 /* written by the corresponding elements of the tridiagonal */ 00091 /* matrix T, and the elements below the first subdiagonal, with */ 00092 /* the array TAU, represent the unitary matrix Q as a product */ 00093 /* of elementary reflectors. See Further Details. */ 00094 00095 /* LDA (input) INTEGER */ 00096 /* The leading dimension of the array A. LDA >= max(1,N). */ 00097 00098 /* D (output) DOUBLE PRECISION array, dimension (N) */ 00099 /* The diagonal elements of the tridiagonal matrix T: */ 00100 /* D(i) = A(i,i). */ 00101 00102 /* E (output) DOUBLE PRECISION array, dimension (N-1) */ 00103 /* The off-diagonal elements of the tridiagonal matrix T: */ 00104 /* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ 00105 00106 /* TAU (output) COMPLEX*16 array, dimension (N-1) */ 00107 /* The scalar factors of the elementary reflectors (see Further */ 00108 /* Details). */ 00109 00110 /* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ 00111 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ 00112 00113 /* LWORK (input) INTEGER */ 00114 /* The dimension of the array WORK. LWORK >= 1. */ 00115 /* For optimum performance LWORK >= N*NB, where NB is the */ 00116 /* optimal blocksize. */ 00117 00118 /* If LWORK = -1, then a workspace query is assumed; the routine */ 00119 /* only calculates the optimal size of the WORK array, returns */ 00120 /* this value as the first entry of the WORK array, and no error */ 00121 /* message related to LWORK is issued by XERBLA. */ 00122 00123 /* INFO (output) INTEGER */ 00124 /* = 0: successful exit */ 00125 /* < 0: if INFO = -i, the i-th argument had an illegal value */ 00126 00127 /* Further Details */ 00128 /* =============== */ 00129 00130 /* If UPLO = 'U', the matrix Q is represented as a product of elementary */ 00131 /* reflectors */ 00132 00133 /* Q = H(n-1) . . . H(2) H(1). */ 00134 00135 /* Each H(i) has the form */ 00136 00137 /* H(i) = I - tau * v * v' */ 00138 00139 /* where tau is a complex scalar, and v is a complex vector with */ 00140 /* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ 00141 /* A(1:i-1,i+1), and tau in TAU(i). */ 00142 00143 /* If UPLO = 'L', the matrix Q is represented as a product of elementary */ 00144 /* reflectors */ 00145 00146 /* Q = H(1) H(2) . . . H(n-1). */ 00147 00148 /* Each H(i) has the form */ 00149 00150 /* H(i) = I - tau * v * v' */ 00151 00152 /* where tau is a complex scalar, and v is a complex vector with */ 00153 /* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ 00154 /* and tau in TAU(i). */ 00155 00156 /* The contents of A on exit are illustrated by the following examples */ 00157 /* with n = 5: */ 00158 00159 /* if UPLO = 'U': if UPLO = 'L': */ 00160 00161 /* ( d e v2 v3 v4 ) ( d ) */ 00162 /* ( d e v3 v4 ) ( e d ) */ 00163 /* ( d e v4 ) ( v1 e d ) */ 00164 /* ( d e ) ( v1 v2 e d ) */ 00165 /* ( d ) ( v1 v2 v3 e d ) */ 00166 00167 /* where d and e denote diagonal and off-diagonal elements of T, and vi */ 00168 /* denotes an element of the vector defining H(i). */ 00169 00170 /* ===================================================================== */ 00171 00172 /* .. Parameters .. */ 00173 /* .. */ 00174 /* .. Local Scalars .. */ 00175 /* .. */ 00176 /* .. External Subroutines .. */ 00177 /* .. */ 00178 /* .. Intrinsic Functions .. */ 00179 /* .. */ 00180 /* .. External Functions .. */ 00181 /* .. */ 00182 /* .. Executable Statements .. */ 00183 00184 /* Test the input parameters */ 00185 00186 /* Parameter adjustments */ 00187 a_dim1 = *lda; 00188 a_offset = 1 + a_dim1; 00189 a -= a_offset; 00190 --d__; 00191 --e; 00192 --tau; 00193 --work; 00194 00195 /* Function Body */ 00196 *info = 0; 00197 upper = lsame_(uplo, "U"); 00198 lquery = *lwork == -1; 00199 if (! upper && ! lsame_(uplo, "L")) { 00200 *info = -1; 00201 } else if (*n < 0) { 00202 *info = -2; 00203 } else if (*lda < max(1,*n)) { 00204 *info = -4; 00205 } else if (*lwork < 1 && ! lquery) { 00206 *info = -9; 00207 } 00208 00209 if (*info == 0) { 00210 00211 /* Determine the block size. */ 00212 00213 nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1); 00214 lwkopt = *n * nb; 00215 work[1].r = (doublereal) lwkopt, work[1].i = 0.; 00216 } 00217 00218 if (*info != 0) { 00219 i__1 = -(*info); 00220 xerbla_("ZHETRD", &i__1); 00221 return 0; 00222 } else if (lquery) { 00223 return 0; 00224 } 00225 00226 /* Quick return if possible */ 00227 00228 if (*n == 0) { 00229 work[1].r = 1., work[1].i = 0.; 00230 return 0; 00231 } 00232 00233 nx = *n; 00234 iws = 1; 00235 if (nb > 1 && nb < *n) { 00236 00237 /* Determine when to cross over from blocked to unblocked code */ 00238 /* (last block is always handled by unblocked code). */ 00239 00240 /* Computing MAX */ 00241 i__1 = nb, i__2 = ilaenv_(&c__3, "ZHETRD", uplo, n, &c_n1, &c_n1, & 00242 c_n1); 00243 nx = max(i__1,i__2); 00244 if (nx < *n) { 00245 00246 /* Determine if workspace is large enough for blocked code. */ 00247 00248 ldwork = *n; 00249 iws = ldwork * nb; 00250 if (*lwork < iws) { 00251 00252 /* Not enough workspace to use optimal NB: determine the */ 00253 /* minimum value of NB, and reduce NB or force use of */ 00254 /* unblocked code by setting NX = N. */ 00255 00256 /* Computing MAX */ 00257 i__1 = *lwork / ldwork; 00258 nb = max(i__1,1); 00259 nbmin = ilaenv_(&c__2, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1); 00260 if (nb < nbmin) { 00261 nx = *n; 00262 } 00263 } 00264 } else { 00265 nx = *n; 00266 } 00267 } else { 00268 nb = 1; 00269 } 00270 00271 if (upper) { 00272 00273 /* Reduce the upper triangle of A. */ 00274 /* Columns 1:kk are handled by the unblocked method. */ 00275 00276 kk = *n - (*n - nx + nb - 1) / nb * nb; 00277 i__1 = kk + 1; 00278 i__2 = -nb; 00279 for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += 00280 i__2) { 00281 00282 /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ 00283 /* matrix W which is needed to update the unreduced part of */ 00284 /* the matrix */ 00285 00286 i__3 = i__ + nb - 1; 00287 zlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & 00288 work[1], &ldwork); 00289 00290 /* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ 00291 /* update of the form: A := A - V*W' - W*V' */ 00292 00293 i__3 = i__ - 1; 00294 z__1.r = -1., z__1.i = -0.; 00295 zher2k_(uplo, "No transpose", &i__3, &nb, &z__1, &a[i__ * a_dim1 00296 + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda); 00297 00298 /* Copy superdiagonal elements back into A, and diagonal */ 00299 /* elements into D */ 00300 00301 i__3 = i__ + nb - 1; 00302 for (j = i__; j <= i__3; ++j) { 00303 i__4 = j - 1 + j * a_dim1; 00304 i__5 = j - 1; 00305 a[i__4].r = e[i__5], a[i__4].i = 0.; 00306 i__4 = j; 00307 i__5 = j + j * a_dim1; 00308 d__[i__4] = a[i__5].r; 00309 /* L10: */ 00310 } 00311 /* L20: */ 00312 } 00313 00314 /* Use unblocked code to reduce the last or only block */ 00315 00316 zhetd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo); 00317 } else { 00318 00319 /* Reduce the lower triangle of A */ 00320 00321 i__2 = *n - nx; 00322 i__1 = nb; 00323 for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { 00324 00325 /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ 00326 /* matrix W which is needed to update the unreduced part of */ 00327 /* the matrix */ 00328 00329 i__3 = *n - i__ + 1; 00330 zlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & 00331 tau[i__], &work[1], &ldwork); 00332 00333 /* Update the unreduced submatrix A(i+nb:n,i+nb:n), using */ 00334 /* an update of the form: A := A - V*W' - W*V' */ 00335 00336 i__3 = *n - i__ - nb + 1; 00337 z__1.r = -1., z__1.i = -0.; 00338 zher2k_(uplo, "No transpose", &i__3, &nb, &z__1, &a[i__ + nb + 00339 i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ 00340 i__ + nb + (i__ + nb) * a_dim1], lda); 00341 00342 /* Copy subdiagonal elements back into A, and diagonal */ 00343 /* elements into D */ 00344 00345 i__3 = i__ + nb - 1; 00346 for (j = i__; j <= i__3; ++j) { 00347 i__4 = j + 1 + j * a_dim1; 00348 i__5 = j; 00349 a[i__4].r = e[i__5], a[i__4].i = 0.; 00350 i__4 = j; 00351 i__5 = j + j * a_dim1; 00352 d__[i__4] = a[i__5].r; 00353 /* L30: */ 00354 } 00355 /* L40: */ 00356 } 00357 00358 /* Use unblocked code to reduce the last or only block */ 00359 00360 i__1 = *n - i__ + 1; 00361 zhetd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], 00362 &tau[i__], &iinfo); 00363 } 00364 00365 work[1].r = (doublereal) lwkopt, work[1].i = 0.; 00366 return 0; 00367 00368 /* End of ZHETRD */ 00369 00370 } /* zhetrd_ */