![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZCHKHB 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE ZCHKHB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, 00012 * THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, 00013 * LWORK, RWORK, RESULT, INFO ) 00014 * 00015 * .. Scalar Arguments .. 00016 * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, 00017 * $ NWDTHS 00018 * DOUBLE PRECISION THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER ISEED( 4 ), KK( * ), NN( * ) 00023 * DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ) 00024 * COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> ZCHKHB tests the reduction of a Hermitian band matrix to tridiagonal 00034 *> from, used with the Hermitian eigenvalue problem. 00035 *> 00036 *> ZHBTRD factors a Hermitian band matrix A as U S U* , where * means 00037 *> conjugate transpose, S is symmetric tridiagonal, and U is unitary. 00038 *> ZHBTRD can use either just the lower or just the upper triangle 00039 *> of A; ZCHKHB checks both cases. 00040 *> 00041 *> When ZCHKHB is called, a number of matrix "sizes" ("n's"), a number 00042 *> of bandwidths ("k's"), and a number of matrix "types" are 00043 *> specified. For each size ("n"), each bandwidth ("k") less than or 00044 *> equal to "n", and each type of matrix, one matrix will be generated 00045 *> and used to test the hermitian banded reduction routine. For each 00046 *> matrix, a number of tests will be performed: 00047 *> 00048 *> (1) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with 00049 *> UPLO='U' 00050 *> 00051 *> (2) | I - UU* | / ( n ulp ) 00052 *> 00053 *> (3) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with 00054 *> UPLO='L' 00055 *> 00056 *> (4) | I - UU* | / ( n ulp ) 00057 *> 00058 *> The "sizes" are specified by an array NN(1:NSIZES); the value of 00059 *> each element NN(j) specifies one size. 00060 *> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); 00061 *> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. 00062 *> Currently, the list of possible types is: 00063 *> 00064 *> (1) The zero matrix. 00065 *> (2) The identity matrix. 00066 *> 00067 *> (3) A diagonal matrix with evenly spaced entries 00068 *> 1, ..., ULP and random signs. 00069 *> (ULP = (first number larger than 1) - 1 ) 00070 *> (4) A diagonal matrix with geometrically spaced entries 00071 *> 1, ..., ULP and random signs. 00072 *> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP 00073 *> and random signs. 00074 *> 00075 *> (6) Same as (4), but multiplied by SQRT( overflow threshold ) 00076 *> (7) Same as (4), but multiplied by SQRT( underflow threshold ) 00077 *> 00078 *> (8) A matrix of the form U* D U, where U is unitary and 00079 *> D has evenly spaced entries 1, ..., ULP with random signs 00080 *> on the diagonal. 00081 *> 00082 *> (9) A matrix of the form U* D U, where U is unitary and 00083 *> D has geometrically spaced entries 1, ..., ULP with random 00084 *> signs on the diagonal. 00085 *> 00086 *> (10) A matrix of the form U* D U, where U is unitary and 00087 *> D has "clustered" entries 1, ULP,..., ULP with random 00088 *> signs on the diagonal. 00089 *> 00090 *> (11) Same as (8), but multiplied by SQRT( overflow threshold ) 00091 *> (12) Same as (8), but multiplied by SQRT( underflow threshold ) 00092 *> 00093 *> (13) Hermitian matrix with random entries chosen from (-1,1). 00094 *> (14) Same as (13), but multiplied by SQRT( overflow threshold ) 00095 *> (15) Same as (13), but multiplied by SQRT( underflow threshold ) 00096 *> \endverbatim 00097 * 00098 * Arguments: 00099 * ========== 00100 * 00101 *> \param[in] NSIZES 00102 *> \verbatim 00103 *> NSIZES is INTEGER 00104 *> The number of sizes of matrices to use. If it is zero, 00105 *> ZCHKHB does nothing. It must be at least zero. 00106 *> \endverbatim 00107 *> 00108 *> \param[in] NN 00109 *> \verbatim 00110 *> NN is INTEGER array, dimension (NSIZES) 00111 *> An array containing the sizes to be used for the matrices. 00112 *> Zero values will be skipped. The values must be at least 00113 *> zero. 00114 *> \endverbatim 00115 *> 00116 *> \param[in] NWDTHS 00117 *> \verbatim 00118 *> NWDTHS is INTEGER 00119 *> The number of bandwidths to use. If it is zero, 00120 *> ZCHKHB does nothing. It must be at least zero. 00121 *> \endverbatim 00122 *> 00123 *> \param[in] KK 00124 *> \verbatim 00125 *> KK is INTEGER array, dimension (NWDTHS) 00126 *> An array containing the bandwidths to be used for the band 00127 *> matrices. The values must be at least zero. 00128 *> \endverbatim 00129 *> 00130 *> \param[in] NTYPES 00131 *> \verbatim 00132 *> NTYPES is INTEGER 00133 *> The number of elements in DOTYPE. If it is zero, ZCHKHB 00134 *> does nothing. It must be at least zero. If it is MAXTYP+1 00135 *> and NSIZES is 1, then an additional type, MAXTYP+1 is 00136 *> defined, which is to use whatever matrix is in A. This 00137 *> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and 00138 *> DOTYPE(MAXTYP+1) is .TRUE. . 00139 *> \endverbatim 00140 *> 00141 *> \param[in] DOTYPE 00142 *> \verbatim 00143 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00144 *> If DOTYPE(j) is .TRUE., then for each size in NN a 00145 *> matrix of that size and of type j will be generated. 00146 *> If NTYPES is smaller than the maximum number of types 00147 *> defined (PARAMETER MAXTYP), then types NTYPES+1 through 00148 *> MAXTYP will not be generated. If NTYPES is larger 00149 *> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) 00150 *> will be ignored. 00151 *> \endverbatim 00152 *> 00153 *> \param[in,out] ISEED 00154 *> \verbatim 00155 *> ISEED is INTEGER array, dimension (4) 00156 *> On entry ISEED specifies the seed of the random number 00157 *> generator. The array elements should be between 0 and 4095; 00158 *> if not they will be reduced mod 4096. Also, ISEED(4) must 00159 *> be odd. The random number generator uses a linear 00160 *> congruential sequence limited to small integers, and so 00161 *> should produce machine independent random numbers. The 00162 *> values of ISEED are changed on exit, and can be used in the 00163 *> next call to ZCHKHB to continue the same random number 00164 *> sequence. 00165 *> \endverbatim 00166 *> 00167 *> \param[in] THRESH 00168 *> \verbatim 00169 *> THRESH is DOUBLE PRECISION 00170 *> A test will count as "failed" if the "error", computed as 00171 *> described above, exceeds THRESH. Note that the error 00172 *> is scaled to be O(1), so THRESH should be a reasonably 00173 *> small multiple of 1, e.g., 10 or 100. In particular, 00174 *> it should not depend on the precision (single vs. double) 00175 *> or the size of the matrix. It must be at least zero. 00176 *> \endverbatim 00177 *> 00178 *> \param[in] NOUNIT 00179 *> \verbatim 00180 *> NOUNIT is INTEGER 00181 *> The FORTRAN unit number for printing out error messages 00182 *> (e.g., if a routine returns IINFO not equal to 0.) 00183 *> \endverbatim 00184 *> 00185 *> \param[in,out] A 00186 *> \verbatim 00187 *> A is COMPLEX*16 array, dimension 00188 *> (LDA, max(NN)) 00189 *> Used to hold the matrix whose eigenvalues are to be 00190 *> computed. 00191 *> \endverbatim 00192 *> 00193 *> \param[in] LDA 00194 *> \verbatim 00195 *> LDA is INTEGER 00196 *> The leading dimension of A. It must be at least 2 (not 1!) 00197 *> and at least max( KK )+1. 00198 *> \endverbatim 00199 *> 00200 *> \param[out] SD 00201 *> \verbatim 00202 *> SD is DOUBLE PRECISION array, dimension (max(NN)) 00203 *> Used to hold the diagonal of the tridiagonal matrix computed 00204 *> by ZHBTRD. 00205 *> \endverbatim 00206 *> 00207 *> \param[out] SE 00208 *> \verbatim 00209 *> SE is DOUBLE PRECISION array, dimension (max(NN)) 00210 *> Used to hold the off-diagonal of the tridiagonal matrix 00211 *> computed by ZHBTRD. 00212 *> \endverbatim 00213 *> 00214 *> \param[out] U 00215 *> \verbatim 00216 *> U is COMPLEX*16 array, dimension (LDU, max(NN)) 00217 *> Used to hold the unitary matrix computed by ZHBTRD. 00218 *> \endverbatim 00219 *> 00220 *> \param[in] LDU 00221 *> \verbatim 00222 *> LDU is INTEGER 00223 *> The leading dimension of U. It must be at least 1 00224 *> and at least max( NN ). 00225 *> \endverbatim 00226 *> 00227 *> \param[out] WORK 00228 *> \verbatim 00229 *> WORK is COMPLEX*16 array, dimension (LWORK) 00230 *> \endverbatim 00231 *> 00232 *> \param[in] LWORK 00233 *> \verbatim 00234 *> LWORK is INTEGER 00235 *> The number of entries in WORK. This must be at least 00236 *> max( LDA+1, max(NN)+1 )*max(NN). 00237 *> \endverbatim 00238 *> 00239 *> \param[out] RWORK 00240 *> \verbatim 00241 *> RWORK is DOUBLE PRECISION array 00242 *> \endverbatim 00243 *> 00244 *> \param[out] RESULT 00245 *> \verbatim 00246 *> RESULT is DOUBLE PRECISION array, dimension (4) 00247 *> The values computed by the tests described above. 00248 *> The values are currently limited to 1/ulp, to avoid 00249 *> overflow. 00250 *> \endverbatim 00251 *> 00252 *> \param[out] INFO 00253 *> \verbatim 00254 *> INFO is INTEGER 00255 *> If 0, then everything ran OK. 00256 *> 00257 *>----------------------------------------------------------------------- 00258 *> 00259 *> Some Local Variables and Parameters: 00260 *> ---- ----- --------- --- ---------- 00261 *> ZERO, ONE Real 0 and 1. 00262 *> MAXTYP The number of types defined. 00263 *> NTEST The number of tests performed, or which can 00264 *> be performed so far, for the current matrix. 00265 *> NTESTT The total number of tests performed so far. 00266 *> NMAX Largest value in NN. 00267 *> NMATS The number of matrices generated so far. 00268 *> NERRS The number of tests which have exceeded THRESH 00269 *> so far. 00270 *> COND, IMODE Values to be passed to the matrix generators. 00271 *> ANORM Norm of A; passed to matrix generators. 00272 *> 00273 *> OVFL, UNFL Overflow and underflow thresholds. 00274 *> ULP, ULPINV Finest relative precision and its inverse. 00275 *> RTOVFL, RTUNFL Square roots of the previous 2 values. 00276 *> The following four arrays decode JTYPE: 00277 *> KTYPE(j) The general type (1-10) for type "j". 00278 *> KMODE(j) The MODE value to be passed to the matrix 00279 *> generator for type "j". 00280 *> KMAGN(j) The order of magnitude ( O(1), 00281 *> O(overflow^(1/2) ), O(underflow^(1/2) ) 00282 *> \endverbatim 00283 * 00284 * Authors: 00285 * ======== 00286 * 00287 *> \author Univ. of Tennessee 00288 *> \author Univ. of California Berkeley 00289 *> \author Univ. of Colorado Denver 00290 *> \author NAG Ltd. 00291 * 00292 *> \date November 2011 00293 * 00294 *> \ingroup complex16_eig 00295 * 00296 * ===================================================================== 00297 SUBROUTINE ZCHKHB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, 00298 $ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, 00299 $ LWORK, RWORK, RESULT, INFO ) 00300 * 00301 * -- LAPACK test routine (version 3.4.0) -- 00302 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00303 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00304 * November 2011 00305 * 00306 * .. Scalar Arguments .. 00307 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, 00308 $ NWDTHS 00309 DOUBLE PRECISION THRESH 00310 * .. 00311 * .. Array Arguments .. 00312 LOGICAL DOTYPE( * ) 00313 INTEGER ISEED( 4 ), KK( * ), NN( * ) 00314 DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ) 00315 COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) 00316 * .. 00317 * 00318 * ===================================================================== 00319 * 00320 * .. Parameters .. 00321 COMPLEX*16 CZERO, CONE 00322 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), 00323 $ CONE = ( 1.0D+0, 0.0D+0 ) ) 00324 DOUBLE PRECISION ZERO, ONE, TWO, TEN 00325 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, 00326 $ TEN = 10.0D+0 ) 00327 DOUBLE PRECISION HALF 00328 PARAMETER ( HALF = ONE / TWO ) 00329 INTEGER MAXTYP 00330 PARAMETER ( MAXTYP = 15 ) 00331 * .. 00332 * .. Local Scalars .. 00333 LOGICAL BADNN, BADNNB 00334 INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, 00335 $ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS, 00336 $ NMATS, NMAX, NTEST, NTESTT 00337 DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, 00338 $ TEMP1, ULP, ULPINV, UNFL 00339 * .. 00340 * .. Local Arrays .. 00341 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), 00342 $ KMODE( MAXTYP ), KTYPE( MAXTYP ) 00343 * .. 00344 * .. External Functions .. 00345 DOUBLE PRECISION DLAMCH 00346 EXTERNAL DLAMCH 00347 * .. 00348 * .. External Subroutines .. 00349 EXTERNAL DLASUM, XERBLA, ZHBT21, ZHBTRD, ZLACPY, ZLASET, 00350 $ ZLATMR, ZLATMS 00351 * .. 00352 * .. Intrinsic Functions .. 00353 INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, SQRT 00354 * .. 00355 * .. Data statements .. 00356 DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / 00357 DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, 00358 $ 2, 3 / 00359 DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, 00360 $ 0, 0 / 00361 * .. 00362 * .. Executable Statements .. 00363 * 00364 * Check for errors 00365 * 00366 NTESTT = 0 00367 INFO = 0 00368 * 00369 * Important constants 00370 * 00371 BADNN = .FALSE. 00372 NMAX = 1 00373 DO 10 J = 1, NSIZES 00374 NMAX = MAX( NMAX, NN( J ) ) 00375 IF( NN( J ).LT.0 ) 00376 $ BADNN = .TRUE. 00377 10 CONTINUE 00378 * 00379 BADNNB = .FALSE. 00380 KMAX = 0 00381 DO 20 J = 1, NSIZES 00382 KMAX = MAX( KMAX, KK( J ) ) 00383 IF( KK( J ).LT.0 ) 00384 $ BADNNB = .TRUE. 00385 20 CONTINUE 00386 KMAX = MIN( NMAX-1, KMAX ) 00387 * 00388 * Check for errors 00389 * 00390 IF( NSIZES.LT.0 ) THEN 00391 INFO = -1 00392 ELSE IF( BADNN ) THEN 00393 INFO = -2 00394 ELSE IF( NWDTHS.LT.0 ) THEN 00395 INFO = -3 00396 ELSE IF( BADNNB ) THEN 00397 INFO = -4 00398 ELSE IF( NTYPES.LT.0 ) THEN 00399 INFO = -5 00400 ELSE IF( LDA.LT.KMAX+1 ) THEN 00401 INFO = -11 00402 ELSE IF( LDU.LT.NMAX ) THEN 00403 INFO = -15 00404 ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN 00405 INFO = -17 00406 END IF 00407 * 00408 IF( INFO.NE.0 ) THEN 00409 CALL XERBLA( 'ZCHKHB', -INFO ) 00410 RETURN 00411 END IF 00412 * 00413 * Quick return if possible 00414 * 00415 IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) 00416 $ RETURN 00417 * 00418 * More Important constants 00419 * 00420 UNFL = DLAMCH( 'Safe minimum' ) 00421 OVFL = ONE / UNFL 00422 ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) 00423 ULPINV = ONE / ULP 00424 RTUNFL = SQRT( UNFL ) 00425 RTOVFL = SQRT( OVFL ) 00426 * 00427 * Loop over sizes, types 00428 * 00429 NERRS = 0 00430 NMATS = 0 00431 * 00432 DO 190 JSIZE = 1, NSIZES 00433 N = NN( JSIZE ) 00434 ANINV = ONE / DBLE( MAX( 1, N ) ) 00435 * 00436 DO 180 JWIDTH = 1, NWDTHS 00437 K = KK( JWIDTH ) 00438 IF( K.GT.N ) 00439 $ GO TO 180 00440 K = MAX( 0, MIN( N-1, K ) ) 00441 * 00442 IF( NSIZES.NE.1 ) THEN 00443 MTYPES = MIN( MAXTYP, NTYPES ) 00444 ELSE 00445 MTYPES = MIN( MAXTYP+1, NTYPES ) 00446 END IF 00447 * 00448 DO 170 JTYPE = 1, MTYPES 00449 IF( .NOT.DOTYPE( JTYPE ) ) 00450 $ GO TO 170 00451 NMATS = NMATS + 1 00452 NTEST = 0 00453 * 00454 DO 30 J = 1, 4 00455 IOLDSD( J ) = ISEED( J ) 00456 30 CONTINUE 00457 * 00458 * Compute "A". 00459 * Store as "Upper"; later, we will copy to other format. 00460 * 00461 * Control parameters: 00462 * 00463 * KMAGN KMODE KTYPE 00464 * =1 O(1) clustered 1 zero 00465 * =2 large clustered 2 identity 00466 * =3 small exponential (none) 00467 * =4 arithmetic diagonal, (w/ eigenvalues) 00468 * =5 random log hermitian, w/ eigenvalues 00469 * =6 random (none) 00470 * =7 random diagonal 00471 * =8 random hermitian 00472 * =9 positive definite 00473 * =10 diagonally dominant tridiagonal 00474 * 00475 IF( MTYPES.GT.MAXTYP ) 00476 $ GO TO 100 00477 * 00478 ITYPE = KTYPE( JTYPE ) 00479 IMODE = KMODE( JTYPE ) 00480 * 00481 * Compute norm 00482 * 00483 GO TO ( 40, 50, 60 )KMAGN( JTYPE ) 00484 * 00485 40 CONTINUE 00486 ANORM = ONE 00487 GO TO 70 00488 * 00489 50 CONTINUE 00490 ANORM = ( RTOVFL*ULP )*ANINV 00491 GO TO 70 00492 * 00493 60 CONTINUE 00494 ANORM = RTUNFL*N*ULPINV 00495 GO TO 70 00496 * 00497 70 CONTINUE 00498 * 00499 CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) 00500 IINFO = 0 00501 IF( JTYPE.LE.15 ) THEN 00502 COND = ULPINV 00503 ELSE 00504 COND = ULPINV*ANINV / TEN 00505 END IF 00506 * 00507 * Special Matrices -- Identity & Jordan block 00508 * 00509 * Zero 00510 * 00511 IF( ITYPE.EQ.1 ) THEN 00512 IINFO = 0 00513 * 00514 ELSE IF( ITYPE.EQ.2 ) THEN 00515 * 00516 * Identity 00517 * 00518 DO 80 JCOL = 1, N 00519 A( K+1, JCOL ) = ANORM 00520 80 CONTINUE 00521 * 00522 ELSE IF( ITYPE.EQ.4 ) THEN 00523 * 00524 * Diagonal Matrix, [Eigen]values Specified 00525 * 00526 CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, 00527 $ COND, ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, 00528 $ WORK, IINFO ) 00529 * 00530 ELSE IF( ITYPE.EQ.5 ) THEN 00531 * 00532 * Hermitian, eigenvalues specified 00533 * 00534 CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, 00535 $ COND, ANORM, K, K, 'Q', A, LDA, WORK, 00536 $ IINFO ) 00537 * 00538 ELSE IF( ITYPE.EQ.7 ) THEN 00539 * 00540 * Diagonal, random eigenvalues 00541 * 00542 CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, 00543 $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, 00544 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, 00545 $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, 00546 $ IDUMMA, IINFO ) 00547 * 00548 ELSE IF( ITYPE.EQ.8 ) THEN 00549 * 00550 * Hermitian, random eigenvalues 00551 * 00552 CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, 00553 $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, 00554 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, 00555 $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) 00556 * 00557 ELSE IF( ITYPE.EQ.9 ) THEN 00558 * 00559 * Positive definite, eigenvalues specified. 00560 * 00561 CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, 00562 $ COND, ANORM, K, K, 'Q', A, LDA, 00563 $ WORK( N+1 ), IINFO ) 00564 * 00565 ELSE IF( ITYPE.EQ.10 ) THEN 00566 * 00567 * Positive definite tridiagonal, eigenvalues specified. 00568 * 00569 IF( N.GT.1 ) 00570 $ K = MAX( 1, K ) 00571 CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, 00572 $ COND, ANORM, 1, 1, 'Q', A( K, 1 ), LDA, 00573 $ WORK, IINFO ) 00574 DO 90 I = 2, N 00575 TEMP1 = ABS( A( K, I ) ) / 00576 $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) 00577 IF( TEMP1.GT.HALF ) THEN 00578 A( K, I ) = HALF*SQRT( ABS( A( K+1, 00579 $ I-1 )*A( K+1, I ) ) ) 00580 END IF 00581 90 CONTINUE 00582 * 00583 ELSE 00584 * 00585 IINFO = 1 00586 END IF 00587 * 00588 IF( IINFO.NE.0 ) THEN 00589 WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, 00590 $ JTYPE, IOLDSD 00591 INFO = ABS( IINFO ) 00592 RETURN 00593 END IF 00594 * 00595 100 CONTINUE 00596 * 00597 * Call ZHBTRD to compute S and U from upper triangle. 00598 * 00599 CALL ZLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) 00600 * 00601 NTEST = 1 00602 CALL ZHBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, 00603 $ WORK( LDA*N+1 ), IINFO ) 00604 * 00605 IF( IINFO.NE.0 ) THEN 00606 WRITE( NOUNIT, FMT = 9999 )'ZHBTRD(U)', IINFO, N, 00607 $ JTYPE, IOLDSD 00608 INFO = ABS( IINFO ) 00609 IF( IINFO.LT.0 ) THEN 00610 RETURN 00611 ELSE 00612 RESULT( 1 ) = ULPINV 00613 GO TO 150 00614 END IF 00615 END IF 00616 * 00617 * Do tests 1 and 2 00618 * 00619 CALL ZHBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, 00620 $ WORK, RWORK, RESULT( 1 ) ) 00621 * 00622 * Convert A from Upper-Triangle-Only storage to 00623 * Lower-Triangle-Only storage. 00624 * 00625 DO 120 JC = 1, N 00626 DO 110 JR = 0, MIN( K, N-JC ) 00627 A( JR+1, JC ) = DCONJG( A( K+1-JR, JC+JR ) ) 00628 110 CONTINUE 00629 120 CONTINUE 00630 DO 140 JC = N + 1 - K, N 00631 DO 130 JR = MIN( K, N-JC ) + 1, K 00632 A( JR+1, JC ) = ZERO 00633 130 CONTINUE 00634 140 CONTINUE 00635 * 00636 * Call ZHBTRD to compute S and U from lower triangle 00637 * 00638 CALL ZLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) 00639 * 00640 NTEST = 3 00641 CALL ZHBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, 00642 $ WORK( LDA*N+1 ), IINFO ) 00643 * 00644 IF( IINFO.NE.0 ) THEN 00645 WRITE( NOUNIT, FMT = 9999 )'ZHBTRD(L)', IINFO, N, 00646 $ JTYPE, IOLDSD 00647 INFO = ABS( IINFO ) 00648 IF( IINFO.LT.0 ) THEN 00649 RETURN 00650 ELSE 00651 RESULT( 3 ) = ULPINV 00652 GO TO 150 00653 END IF 00654 END IF 00655 NTEST = 4 00656 * 00657 * Do tests 3 and 4 00658 * 00659 CALL ZHBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, 00660 $ WORK, RWORK, RESULT( 3 ) ) 00661 * 00662 * End of Loop -- Check for RESULT(j) > THRESH 00663 * 00664 150 CONTINUE 00665 NTESTT = NTESTT + NTEST 00666 * 00667 * Print out tests which fail. 00668 * 00669 DO 160 JR = 1, NTEST 00670 IF( RESULT( JR ).GE.THRESH ) THEN 00671 * 00672 * If this is the first test to fail, 00673 * print a header to the data file. 00674 * 00675 IF( NERRS.EQ.0 ) THEN 00676 WRITE( NOUNIT, FMT = 9998 )'ZHB' 00677 WRITE( NOUNIT, FMT = 9997 ) 00678 WRITE( NOUNIT, FMT = 9996 ) 00679 WRITE( NOUNIT, FMT = 9995 )'Hermitian' 00680 WRITE( NOUNIT, FMT = 9994 )'unitary', '*', 00681 $ 'conjugate transpose', ( '*', J = 1, 4 ) 00682 END IF 00683 NERRS = NERRS + 1 00684 WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, 00685 $ JR, RESULT( JR ) 00686 END IF 00687 160 CONTINUE 00688 * 00689 170 CONTINUE 00690 180 CONTINUE 00691 190 CONTINUE 00692 * 00693 * Summary 00694 * 00695 CALL DLASUM( 'ZHB', NOUNIT, NERRS, NTESTT ) 00696 RETURN 00697 * 00698 9999 FORMAT( ' ZCHKHB: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', 00699 $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) 00700 9998 FORMAT( / 1X, A3, 00701 $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines' 00702 $ ) 00703 9997 FORMAT( ' Matrix types (see DCHK23 for details): ' ) 00704 * 00705 9996 FORMAT( / ' Special Matrices:', 00706 $ / ' 1=Zero matrix. ', 00707 $ ' 5=Diagonal: clustered entries.', 00708 $ / ' 2=Identity matrix. ', 00709 $ ' 6=Diagonal: large, evenly spaced.', 00710 $ / ' 3=Diagonal: evenly spaced entries. ', 00711 $ ' 7=Diagonal: small, evenly spaced.', 00712 $ / ' 4=Diagonal: geometr. spaced entries.' ) 00713 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', 00714 $ / ' 8=Evenly spaced eigenvals. ', 00715 $ ' 12=Small, evenly spaced eigenvals.', 00716 $ / ' 9=Geometrically spaced eigenvals. ', 00717 $ ' 13=Matrix with random O(1) entries.', 00718 $ / ' 10=Clustered eigenvalues. ', 00719 $ ' 14=Matrix with large random entries.', 00720 $ / ' 11=Large, evenly spaced eigenvals. ', 00721 $ ' 15=Matrix with small random entries.' ) 00722 * 00723 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', 00724 $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', 00725 $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', 00726 $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', 00727 $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', 00728 $ ' 4= | I - U U', A1, ' | / ( n ulp )' ) 00729 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', 00730 $ I2, ', test(', I2, ')=', G10.3 ) 00731 * 00732 * End of ZCHKHB 00733 * 00734 END