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