|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE CDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, 00002 $ NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, 00003 $ LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, 00004 $ IWORK, LIWORK, RESULT, INFO ) 00005 * 00006 * -- LAPACK test routine (version 3.1) -- 00007 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00008 * November 2006 00009 * 00010 * .. Scalar Arguments .. 00011 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, 00012 $ NSIZES, NTYPES 00013 REAL THRESH 00014 * .. 00015 * .. Array Arguments .. 00016 LOGICAL DOTYPE( * ) 00017 INTEGER ISEED( 4 ), IWORK( * ), NN( * ) 00018 REAL D1( * ), D2( * ), D3( * ), RESULT( * ), 00019 $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) 00020 COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), 00021 $ V( LDU, * ), WORK( * ), Z( LDU, * ) 00022 * .. 00023 * 00024 * Purpose 00025 * ======= 00026 * 00027 * CDRVST checks the Hermitian eigenvalue problem drivers. 00028 * 00029 * CHEEVD computes all eigenvalues and, optionally, 00030 * eigenvectors of a complex Hermitian matrix, 00031 * using a divide-and-conquer algorithm. 00032 * 00033 * CHEEVX computes selected eigenvalues and, optionally, 00034 * eigenvectors of a complex Hermitian matrix. 00035 * 00036 * CHEEVR computes selected eigenvalues and, optionally, 00037 * eigenvectors of a complex Hermitian matrix 00038 * using the Relatively Robust Representation where it can. 00039 * 00040 * CHPEVD computes all eigenvalues and, optionally, 00041 * eigenvectors of a complex Hermitian matrix in packed 00042 * storage, using a divide-and-conquer algorithm. 00043 * 00044 * CHPEVX computes selected eigenvalues and, optionally, 00045 * eigenvectors of a complex Hermitian matrix in packed 00046 * storage. 00047 * 00048 * CHBEVD computes all eigenvalues and, optionally, 00049 * eigenvectors of a complex Hermitian band matrix, 00050 * using a divide-and-conquer algorithm. 00051 * 00052 * CHBEVX computes selected eigenvalues and, optionally, 00053 * eigenvectors of a complex Hermitian band matrix. 00054 * 00055 * CHEEV computes all eigenvalues and, optionally, 00056 * eigenvectors of a complex Hermitian matrix. 00057 * 00058 * CHPEV computes all eigenvalues and, optionally, 00059 * eigenvectors of a complex Hermitian matrix in packed 00060 * storage. 00061 * 00062 * CHBEV computes all eigenvalues and, optionally, 00063 * eigenvectors of a complex Hermitian band matrix. 00064 * 00065 * When CDRVST is called, a number of matrix "sizes" ("n's") and a 00066 * number of matrix "types" are specified. For each size ("n") 00067 * and each type of matrix, one matrix will be generated and used 00068 * to test the appropriate drivers. For each matrix and each 00069 * driver routine called, the following tests will be performed: 00070 * 00071 * (1) | A - Z D Z' | / ( |A| n ulp ) 00072 * 00073 * (2) | I - Z Z' | / ( n ulp ) 00074 * 00075 * (3) | D1 - D2 | / ( |D1| ulp ) 00076 * 00077 * where Z is the matrix of eigenvectors returned when the 00078 * eigenvector option is given and D1 and D2 are the eigenvalues 00079 * returned with and without the eigenvector option. 00080 * 00081 * The "sizes" are specified by an array NN(1:NSIZES); the value of 00082 * each element NN(j) specifies one size. 00083 * The "types" are specified by a logical array DOTYPE( 1:NTYPES ); 00084 * if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. 00085 * Currently, the list of possible types is: 00086 * 00087 * (1) The zero matrix. 00088 * (2) The identity matrix. 00089 * 00090 * (3) A diagonal matrix with evenly spaced entries 00091 * 1, ..., ULP and random signs. 00092 * (ULP = (first number larger than 1) - 1 ) 00093 * (4) A diagonal matrix with geometrically spaced entries 00094 * 1, ..., ULP and random signs. 00095 * (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP 00096 * and random signs. 00097 * 00098 * (6) Same as (4), but multiplied by SQRT( overflow threshold ) 00099 * (7) Same as (4), but multiplied by SQRT( underflow threshold ) 00100 * 00101 * (8) A matrix of the form U* D U, where U is unitary and 00102 * D has evenly spaced entries 1, ..., ULP with random signs 00103 * on the diagonal. 00104 * 00105 * (9) A matrix of the form U* D U, where U is unitary and 00106 * D has geometrically spaced entries 1, ..., ULP with random 00107 * signs on the diagonal. 00108 * 00109 * (10) A matrix of the form U* D U, where U is unitary and 00110 * D has "clustered" entries 1, ULP,..., ULP with random 00111 * signs on the diagonal. 00112 * 00113 * (11) Same as (8), but multiplied by SQRT( overflow threshold ) 00114 * (12) Same as (8), but multiplied by SQRT( underflow threshold ) 00115 * 00116 * (13) Symmetric matrix with random entries chosen from (-1,1). 00117 * (14) Same as (13), but multiplied by SQRT( overflow threshold ) 00118 * (15) Same as (13), but multiplied by SQRT( underflow threshold ) 00119 * (16) A band matrix with half bandwidth randomly chosen between 00120 * 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP 00121 * with random signs. 00122 * (17) Same as (16), but multiplied by SQRT( overflow threshold ) 00123 * (18) Same as (16), but multiplied by SQRT( underflow threshold ) 00124 * 00125 * Arguments 00126 * ========= 00127 * 00128 * NSIZES INTEGER 00129 * The number of sizes of matrices to use. If it is zero, 00130 * CDRVST does nothing. It must be at least zero. 00131 * Not modified. 00132 * 00133 * NN INTEGER array, dimension (NSIZES) 00134 * An array containing the sizes to be used for the matrices. 00135 * Zero values will be skipped. The values must be at least 00136 * zero. 00137 * Not modified. 00138 * 00139 * NTYPES INTEGER 00140 * The number of elements in DOTYPE. If it is zero, CDRVST 00141 * does nothing. It must be at least zero. If it is MAXTYP+1 00142 * and NSIZES is 1, then an additional type, MAXTYP+1 is 00143 * defined, which is to use whatever matrix is in A. This 00144 * is only useful if DOTYPE(1:MAXTYP) is .FALSE. and 00145 * DOTYPE(MAXTYP+1) is .TRUE. . 00146 * Not modified. 00147 * 00148 * DOTYPE LOGICAL array, dimension (NTYPES) 00149 * If DOTYPE(j) is .TRUE., then for each size in NN a 00150 * matrix of that size and of type j will be generated. 00151 * If NTYPES is smaller than the maximum number of types 00152 * defined (PARAMETER MAXTYP), then types NTYPES+1 through 00153 * MAXTYP will not be generated. If NTYPES is larger 00154 * than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) 00155 * will be ignored. 00156 * Not modified. 00157 * 00158 * ISEED INTEGER array, dimension (4) 00159 * On entry ISEED specifies the seed of the random number 00160 * generator. The array elements should be between 0 and 4095; 00161 * if not they will be reduced mod 4096. Also, ISEED(4) must 00162 * be odd. The random number generator uses a linear 00163 * congruential sequence limited to small integers, and so 00164 * should produce machine independent random numbers. The 00165 * values of ISEED are changed on exit, and can be used in the 00166 * next call to CDRVST to continue the same random number 00167 * sequence. 00168 * Modified. 00169 * 00170 * THRESH REAL 00171 * A test will count as "failed" if the "error", computed as 00172 * described above, exceeds THRESH. Note that the error 00173 * is scaled to be O(1), so THRESH should be a reasonably 00174 * small multiple of 1, e.g., 10 or 100. In particular, 00175 * it should not depend on the precision (single vs. double) 00176 * or the size of the matrix. It must be at least zero. 00177 * Not modified. 00178 * 00179 * NOUNIT INTEGER 00180 * The FORTRAN unit number for printing out error messages 00181 * (e.g., if a routine returns IINFO not equal to 0.) 00182 * Not modified. 00183 * 00184 * A COMPLEX array, dimension (LDA , max(NN)) 00185 * Used to hold the matrix whose eigenvalues are to be 00186 * computed. On exit, A contains the last matrix actually 00187 * used. 00188 * Modified. 00189 * 00190 * LDA INTEGER 00191 * The leading dimension of A. It must be at 00192 * least 1 and at least max( NN ). 00193 * Not modified. 00194 * 00195 * D1 REAL array, dimension (max(NN)) 00196 * The eigenvalues of A, as computed by CSTEQR simlutaneously 00197 * with Z. On exit, the eigenvalues in D1 correspond with the 00198 * matrix in A. 00199 * Modified. 00200 * 00201 * D2 REAL array, dimension (max(NN)) 00202 * The eigenvalues of A, as computed by CSTEQR if Z is not 00203 * computed. On exit, the eigenvalues in D2 correspond with 00204 * the matrix in A. 00205 * Modified. 00206 * 00207 * D3 REAL array, dimension (max(NN)) 00208 * The eigenvalues of A, as computed by SSTERF. On exit, the 00209 * eigenvalues in D3 correspond with the matrix in A. 00210 * Modified. 00211 * 00212 * WA1 REAL array, dimension 00213 * 00214 * WA2 REAL array, dimension 00215 * 00216 * WA3 REAL array, dimension 00217 * 00218 * U COMPLEX array, dimension (LDU, max(NN)) 00219 * The unitary matrix computed by CHETRD + CUNGC3. 00220 * Modified. 00221 * 00222 * LDU INTEGER 00223 * The leading dimension of U, Z, and V. It must be at 00224 * least 1 and at least max( NN ). 00225 * Not modified. 00226 * 00227 * V COMPLEX array, dimension (LDU, max(NN)) 00228 * The Housholder vectors computed by CHETRD in reducing A to 00229 * tridiagonal form. 00230 * Modified. 00231 * 00232 * TAU COMPLEX array, dimension (max(NN)) 00233 * The Householder factors computed by CHETRD in reducing A 00234 * to tridiagonal form. 00235 * Modified. 00236 * 00237 * Z COMPLEX array, dimension (LDU, max(NN)) 00238 * The unitary matrix of eigenvectors computed by CHEEVD, 00239 * CHEEVX, CHPEVD, CHPEVX, CHBEVD, and CHBEVX. 00240 * Modified. 00241 * 00242 * WORK - COMPLEX array of dimension ( LWORK ) 00243 * Workspace. 00244 * Modified. 00245 * 00246 * LWORK - INTEGER 00247 * The number of entries in WORK. This must be at least 00248 * 2*max( NN(j), 2 )**2. 00249 * Not modified. 00250 * 00251 * RWORK REAL array, dimension (3*max(NN)) 00252 * Workspace. 00253 * Modified. 00254 * 00255 * LRWORK - INTEGER 00256 * The number of entries in RWORK. 00257 * 00258 * IWORK INTEGER array, dimension (6*max(NN)) 00259 * Workspace. 00260 * Modified. 00261 * 00262 * LIWORK - INTEGER 00263 * The number of entries in IWORK. 00264 * 00265 * RESULT REAL array, dimension (??) 00266 * The values computed by the tests described above. 00267 * The values are currently limited to 1/ulp, to avoid 00268 * overflow. 00269 * Modified. 00270 * 00271 * INFO INTEGER 00272 * If 0, then everything ran OK. 00273 * -1: NSIZES < 0 00274 * -2: Some NN(j) < 0 00275 * -3: NTYPES < 0 00276 * -5: THRESH < 0 00277 * -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). 00278 * -16: LDU < 1 or LDU < NMAX. 00279 * -21: LWORK too small. 00280 * If SLATMR, SLATMS, CHETRD, SORGC3, CSTEQR, SSTERF, 00281 * or SORMC2 returns an error code, the 00282 * absolute value of it is returned. 00283 * Modified. 00284 * 00285 *----------------------------------------------------------------------- 00286 * 00287 * Some Local Variables and Parameters: 00288 * ---- ----- --------- --- ---------- 00289 * ZERO, ONE Real 0 and 1. 00290 * MAXTYP The number of types defined. 00291 * NTEST The number of tests performed, or which can 00292 * be performed so far, for the current matrix. 00293 * NTESTT The total number of tests performed so far. 00294 * NMAX Largest value in NN. 00295 * NMATS The number of matrices generated so far. 00296 * NERRS The number of tests which have exceeded THRESH 00297 * so far (computed by SLAFTS). 00298 * COND, IMODE Values to be passed to the matrix generators. 00299 * ANORM Norm of A; passed to matrix generators. 00300 * 00301 * OVFL, UNFL Overflow and underflow thresholds. 00302 * ULP, ULPINV Finest relative precision and its inverse. 00303 * RTOVFL, RTUNFL Square roots of the previous 2 values. 00304 * The following four arrays decode JTYPE: 00305 * KTYPE(j) The general type (1-10) for type "j". 00306 * KMODE(j) The MODE value to be passed to the matrix 00307 * generator for type "j". 00308 * KMAGN(j) The order of magnitude ( O(1), 00309 * O(overflow^(1/2) ), O(underflow^(1/2) ) 00310 * 00311 * ===================================================================== 00312 * 00313 * 00314 * .. Parameters .. 00315 REAL ZERO, ONE, TWO, TEN 00316 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0, 00317 $ TEN = 10.0E+0 ) 00318 REAL HALF 00319 PARAMETER ( HALF = ONE / TWO ) 00320 COMPLEX CZERO, CONE 00321 PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), 00322 $ CONE = ( 1.0E+0, 0.0E+0 ) ) 00323 INTEGER MAXTYP 00324 PARAMETER ( MAXTYP = 18 ) 00325 * .. 00326 * .. Local Scalars .. 00327 LOGICAL BADNN 00328 CHARACTER UPLO 00329 INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDWRK, INDX, 00330 $ IROW, ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, 00331 $ JSIZE, JTYPE, KD, LGN, LIWEDC, LRWEDC, LWEDC, 00332 $ M, M2, M3, MTYPES, N, NERRS, NMATS, NMAX, 00333 $ NTEST, NTESTT 00334 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, 00335 $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, 00336 $ VL, VU 00337 * .. 00338 * .. Local Arrays .. 00339 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), 00340 $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), 00341 $ KTYPE( MAXTYP ) 00342 * .. 00343 * .. External Functions .. 00344 REAL SLAMCH, SLARND, SSXT1 00345 EXTERNAL SLAMCH, SLARND, SSXT1 00346 * .. 00347 * .. External Subroutines .. 00348 EXTERNAL ALASVM, CHBEV, CHBEVD, CHBEVX, CHEEV, CHEEVD, 00349 $ CHEEVR, CHEEVX, CHET21, CHET22, CHPEV, CHPEVD, 00350 $ CHPEVX, CLACPY, CLASET, CLATMR, CLATMS, SLABAD, 00351 $ SLAFTS, XERBLA 00352 * .. 00353 * .. Intrinsic Functions .. 00354 INTRINSIC ABS, INT, LOG, MAX, MIN, REAL, SQRT 00355 * .. 00356 * .. Data statements .. 00357 DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / 00358 DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, 00359 $ 2, 3, 1, 2, 3 / 00360 DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, 00361 $ 0, 0, 4, 4, 4 / 00362 * .. 00363 * .. Executable Statements .. 00364 * 00365 * 1) Check for errors 00366 * 00367 NTESTT = 0 00368 INFO = 0 00369 * 00370 BADNN = .FALSE. 00371 NMAX = 1 00372 DO 10 J = 1, NSIZES 00373 NMAX = MAX( NMAX, NN( J ) ) 00374 IF( NN( J ).LT.0 ) 00375 $ BADNN = .TRUE. 00376 10 CONTINUE 00377 * 00378 * Check for errors 00379 * 00380 IF( NSIZES.LT.0 ) THEN 00381 INFO = -1 00382 ELSE IF( BADNN ) THEN 00383 INFO = -2 00384 ELSE IF( NTYPES.LT.0 ) THEN 00385 INFO = -3 00386 ELSE IF( LDA.LT.NMAX ) THEN 00387 INFO = -9 00388 ELSE IF( LDU.LT.NMAX ) THEN 00389 INFO = -16 00390 ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN 00391 INFO = -22 00392 END IF 00393 * 00394 IF( INFO.NE.0 ) THEN 00395 CALL XERBLA( 'CDRVST', -INFO ) 00396 RETURN 00397 END IF 00398 * 00399 * Quick return if nothing to do 00400 * 00401 IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) 00402 $ RETURN 00403 * 00404 * More Important constants 00405 * 00406 UNFL = SLAMCH( 'Safe minimum' ) 00407 OVFL = SLAMCH( 'Overflow' ) 00408 CALL SLABAD( UNFL, OVFL ) 00409 ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) 00410 ULPINV = ONE / ULP 00411 RTUNFL = SQRT( UNFL ) 00412 RTOVFL = SQRT( OVFL ) 00413 * 00414 * Loop over sizes, types 00415 * 00416 DO 20 I = 1, 4 00417 ISEED2( I ) = ISEED( I ) 00418 ISEED3( I ) = ISEED( I ) 00419 20 CONTINUE 00420 * 00421 NERRS = 0 00422 NMATS = 0 00423 * 00424 DO 1220 JSIZE = 1, NSIZES 00425 N = NN( JSIZE ) 00426 IF( N.GT.0 ) THEN 00427 LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) 00428 IF( 2**LGN.LT.N ) 00429 $ LGN = LGN + 1 00430 IF( 2**LGN.LT.N ) 00431 $ LGN = LGN + 1 00432 LWEDC = MAX( 2*N+N*N, 2*N*N ) 00433 LRWEDC = 1 + 4*N + 2*N*LGN + 3*N**2 00434 LIWEDC = 3 + 5*N 00435 ELSE 00436 LWEDC = 2 00437 LRWEDC = 8 00438 LIWEDC = 8 00439 END IF 00440 ANINV = ONE / REAL( MAX( 1, N ) ) 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 1210 JTYPE = 1, MTYPES 00449 IF( .NOT.DOTYPE( JTYPE ) ) 00450 $ GO TO 1210 00451 NMATS = NMATS + 1 00452 NTEST = 0 00453 * 00454 DO 30 J = 1, 4 00455 IOLDSD( J ) = ISEED( J ) 00456 30 CONTINUE 00457 * 00458 * 2) Compute "A" 00459 * 00460 * Control parameters: 00461 * 00462 * KMAGN KMODE KTYPE 00463 * =1 O(1) clustered 1 zero 00464 * =2 large clustered 2 identity 00465 * =3 small exponential (none) 00466 * =4 arithmetic diagonal, (w/ eigenvalues) 00467 * =5 random log Hermitian, w/ eigenvalues 00468 * =6 random (none) 00469 * =7 random diagonal 00470 * =8 random Hermitian 00471 * =9 band Hermitian, w/ eigenvalues 00472 * 00473 IF( MTYPES.GT.MAXTYP ) 00474 $ GO TO 110 00475 * 00476 ITYPE = KTYPE( JTYPE ) 00477 IMODE = KMODE( JTYPE ) 00478 * 00479 * Compute norm 00480 * 00481 GO TO ( 40, 50, 60 )KMAGN( JTYPE ) 00482 * 00483 40 CONTINUE 00484 ANORM = ONE 00485 GO TO 70 00486 * 00487 50 CONTINUE 00488 ANORM = ( RTOVFL*ULP )*ANINV 00489 GO TO 70 00490 * 00491 60 CONTINUE 00492 ANORM = RTUNFL*N*ULPINV 00493 GO TO 70 00494 * 00495 70 CONTINUE 00496 * 00497 CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) 00498 IINFO = 0 00499 COND = ULPINV 00500 * 00501 * Special Matrices -- Identity & Jordan block 00502 * 00503 * Zero 00504 * 00505 IF( ITYPE.EQ.1 ) THEN 00506 IINFO = 0 00507 * 00508 ELSE IF( ITYPE.EQ.2 ) THEN 00509 * 00510 * Identity 00511 * 00512 DO 80 JCOL = 1, N 00513 A( JCOL, JCOL ) = ANORM 00514 80 CONTINUE 00515 * 00516 ELSE IF( ITYPE.EQ.4 ) THEN 00517 * 00518 * Diagonal Matrix, [Eigen]values Specified 00519 * 00520 CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, 00521 $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) 00522 * 00523 ELSE IF( ITYPE.EQ.5 ) THEN 00524 * 00525 * Hermitian, eigenvalues specified 00526 * 00527 CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, 00528 $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) 00529 * 00530 ELSE IF( ITYPE.EQ.7 ) THEN 00531 * 00532 * Diagonal, random eigenvalues 00533 * 00534 CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, 00535 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00536 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, 00537 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00538 * 00539 ELSE IF( ITYPE.EQ.8 ) THEN 00540 * 00541 * Hermitian, random eigenvalues 00542 * 00543 CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, 00544 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00545 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, 00546 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00547 * 00548 ELSE IF( ITYPE.EQ.9 ) THEN 00549 * 00550 * Hermitian banded, eigenvalues specified 00551 * 00552 IHBW = INT( ( N-1 )*SLARND( 1, ISEED3 ) ) 00553 CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, 00554 $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK, 00555 $ IINFO ) 00556 * 00557 * Store as dense matrix for most routines. 00558 * 00559 CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) 00560 DO 100 IDIAG = -IHBW, IHBW 00561 IROW = IHBW - IDIAG + 1 00562 J1 = MAX( 1, IDIAG+1 ) 00563 J2 = MIN( N, N+IDIAG ) 00564 DO 90 J = J1, J2 00565 I = J - IDIAG 00566 A( I, J ) = U( IROW, J ) 00567 90 CONTINUE 00568 100 CONTINUE 00569 ELSE 00570 IINFO = 1 00571 END IF 00572 * 00573 IF( IINFO.NE.0 ) THEN 00574 WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, 00575 $ IOLDSD 00576 INFO = ABS( IINFO ) 00577 RETURN 00578 END IF 00579 * 00580 110 CONTINUE 00581 * 00582 ABSTOL = UNFL + UNFL 00583 IF( N.LE.1 ) THEN 00584 IL = 1 00585 IU = N 00586 ELSE 00587 IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) 00588 IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) 00589 IF( IL.GT.IU ) THEN 00590 ITEMP = IL 00591 IL = IU 00592 IU = ITEMP 00593 END IF 00594 END IF 00595 * 00596 * Perform tests storing upper or lower triangular 00597 * part of matrix. 00598 * 00599 DO 1200 IUPLO = 0, 1 00600 IF( IUPLO.EQ.0 ) THEN 00601 UPLO = 'L' 00602 ELSE 00603 UPLO = 'U' 00604 END IF 00605 * 00606 * Call CHEEVD and CHEEVX. 00607 * 00608 CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) 00609 * 00610 NTEST = NTEST + 1 00611 CALL CHEEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, 00612 $ RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) 00613 IF( IINFO.NE.0 ) THEN 00614 WRITE( NOUNIT, FMT = 9999 )'CHEEVD(V,' // UPLO // 00615 $ ')', IINFO, N, JTYPE, IOLDSD 00616 INFO = ABS( IINFO ) 00617 IF( IINFO.LT.0 ) THEN 00618 RETURN 00619 ELSE 00620 RESULT( NTEST ) = ULPINV 00621 RESULT( NTEST+1 ) = ULPINV 00622 RESULT( NTEST+2 ) = ULPINV 00623 GO TO 130 00624 END IF 00625 END IF 00626 * 00627 * Do tests 1 and 2. 00628 * 00629 CALL CHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, 00630 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 00631 * 00632 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00633 * 00634 NTEST = NTEST + 2 00635 CALL CHEEVD( 'N', UPLO, N, A, LDU, D3, WORK, LWEDC, 00636 $ RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) 00637 IF( IINFO.NE.0 ) THEN 00638 WRITE( NOUNIT, FMT = 9999 )'CHEEVD(N,' // UPLO // 00639 $ ')', IINFO, N, JTYPE, IOLDSD 00640 INFO = ABS( IINFO ) 00641 IF( IINFO.LT.0 ) THEN 00642 RETURN 00643 ELSE 00644 RESULT( NTEST ) = ULPINV 00645 GO TO 130 00646 END IF 00647 END IF 00648 * 00649 * Do test 3. 00650 * 00651 TEMP1 = ZERO 00652 TEMP2 = ZERO 00653 DO 120 J = 1, N 00654 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) 00655 TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) 00656 120 CONTINUE 00657 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 00658 $ ULP*MAX( TEMP1, TEMP2 ) ) 00659 * 00660 130 CONTINUE 00661 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00662 * 00663 NTEST = NTEST + 1 00664 * 00665 IF( N.GT.0 ) THEN 00666 TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) 00667 IF( IL.NE.1 ) THEN 00668 VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), 00669 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00670 ELSE IF( N.GT.0 ) THEN 00671 VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), 00672 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00673 END IF 00674 IF( IU.NE.N ) THEN 00675 VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), 00676 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00677 ELSE IF( N.GT.0 ) THEN 00678 VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), 00679 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00680 END IF 00681 ELSE 00682 TEMP3 = ZERO 00683 VL = ZERO 00684 VU = ONE 00685 END IF 00686 * 00687 CALL CHEEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, 00688 $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, RWORK, 00689 $ IWORK, IWORK( 5*N+1 ), IINFO ) 00690 IF( IINFO.NE.0 ) THEN 00691 WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,A,' // UPLO // 00692 $ ')', IINFO, N, JTYPE, IOLDSD 00693 INFO = ABS( IINFO ) 00694 IF( IINFO.LT.0 ) THEN 00695 RETURN 00696 ELSE 00697 RESULT( NTEST ) = ULPINV 00698 RESULT( NTEST+1 ) = ULPINV 00699 RESULT( NTEST+2 ) = ULPINV 00700 GO TO 150 00701 END IF 00702 END IF 00703 * 00704 * Do tests 4 and 5. 00705 * 00706 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00707 * 00708 CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, 00709 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 00710 * 00711 NTEST = NTEST + 2 00712 CALL CHEEVX( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, 00713 $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, 00714 $ IWORK, IWORK( 5*N+1 ), IINFO ) 00715 IF( IINFO.NE.0 ) THEN 00716 WRITE( NOUNIT, FMT = 9999 )'CHEEVX(N,A,' // UPLO // 00717 $ ')', IINFO, N, JTYPE, IOLDSD 00718 INFO = ABS( IINFO ) 00719 IF( IINFO.LT.0 ) THEN 00720 RETURN 00721 ELSE 00722 RESULT( NTEST ) = ULPINV 00723 GO TO 150 00724 END IF 00725 END IF 00726 * 00727 * Do test 6. 00728 * 00729 TEMP1 = ZERO 00730 TEMP2 = ZERO 00731 DO 140 J = 1, N 00732 TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) 00733 TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) 00734 140 CONTINUE 00735 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 00736 $ ULP*MAX( TEMP1, TEMP2 ) ) 00737 * 00738 150 CONTINUE 00739 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00740 * 00741 NTEST = NTEST + 1 00742 * 00743 CALL CHEEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, 00744 $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, 00745 $ IWORK, IWORK( 5*N+1 ), IINFO ) 00746 IF( IINFO.NE.0 ) THEN 00747 WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,I,' // UPLO // 00748 $ ')', IINFO, N, JTYPE, IOLDSD 00749 INFO = ABS( IINFO ) 00750 IF( IINFO.LT.0 ) THEN 00751 RETURN 00752 ELSE 00753 RESULT( NTEST ) = ULPINV 00754 GO TO 160 00755 END IF 00756 END IF 00757 * 00758 * Do tests 7 and 8. 00759 * 00760 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00761 * 00762 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 00763 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 00764 * 00765 NTEST = NTEST + 2 00766 * 00767 CALL CHEEVX( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, 00768 $ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, RWORK, 00769 $ IWORK, IWORK( 5*N+1 ), IINFO ) 00770 IF( IINFO.NE.0 ) THEN 00771 WRITE( NOUNIT, FMT = 9999 )'CHEEVX(N,I,' // UPLO // 00772 $ ')', IINFO, N, JTYPE, IOLDSD 00773 INFO = ABS( IINFO ) 00774 IF( IINFO.LT.0 ) THEN 00775 RETURN 00776 ELSE 00777 RESULT( NTEST ) = ULPINV 00778 GO TO 160 00779 END IF 00780 END IF 00781 * 00782 * Do test 9. 00783 * 00784 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 00785 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 00786 IF( N.GT.0 ) THEN 00787 TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) 00788 ELSE 00789 TEMP3 = ZERO 00790 END IF 00791 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 00792 $ MAX( UNFL, TEMP3*ULP ) 00793 * 00794 160 CONTINUE 00795 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00796 * 00797 NTEST = NTEST + 1 00798 * 00799 CALL CHEEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, 00800 $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, 00801 $ IWORK, IWORK( 5*N+1 ), IINFO ) 00802 IF( IINFO.NE.0 ) THEN 00803 WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,V,' // UPLO // 00804 $ ')', IINFO, N, JTYPE, IOLDSD 00805 INFO = ABS( IINFO ) 00806 IF( IINFO.LT.0 ) THEN 00807 RETURN 00808 ELSE 00809 RESULT( NTEST ) = ULPINV 00810 GO TO 170 00811 END IF 00812 END IF 00813 * 00814 * Do tests 10 and 11. 00815 * 00816 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00817 * 00818 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 00819 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 00820 * 00821 NTEST = NTEST + 2 00822 * 00823 CALL CHEEVX( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, 00824 $ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, RWORK, 00825 $ IWORK, IWORK( 5*N+1 ), IINFO ) 00826 IF( IINFO.NE.0 ) THEN 00827 WRITE( NOUNIT, FMT = 9999 )'CHEEVX(N,V,' // UPLO // 00828 $ ')', IINFO, N, JTYPE, IOLDSD 00829 INFO = ABS( IINFO ) 00830 IF( IINFO.LT.0 ) THEN 00831 RETURN 00832 ELSE 00833 RESULT( NTEST ) = ULPINV 00834 GO TO 170 00835 END IF 00836 END IF 00837 * 00838 IF( M3.EQ.0 .AND. N.GT.0 ) THEN 00839 RESULT( NTEST ) = ULPINV 00840 GO TO 170 00841 END IF 00842 * 00843 * Do test 12. 00844 * 00845 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 00846 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 00847 IF( N.GT.0 ) THEN 00848 TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) 00849 ELSE 00850 TEMP3 = ZERO 00851 END IF 00852 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 00853 $ MAX( UNFL, TEMP3*ULP ) 00854 * 00855 170 CONTINUE 00856 * 00857 * Call CHPEVD and CHPEVX. 00858 * 00859 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 00860 * 00861 * Load array WORK with the upper or lower triangular 00862 * part of the matrix in packed form. 00863 * 00864 IF( IUPLO.EQ.1 ) THEN 00865 INDX = 1 00866 DO 190 J = 1, N 00867 DO 180 I = 1, J 00868 WORK( INDX ) = A( I, J ) 00869 INDX = INDX + 1 00870 180 CONTINUE 00871 190 CONTINUE 00872 ELSE 00873 INDX = 1 00874 DO 210 J = 1, N 00875 DO 200 I = J, N 00876 WORK( INDX ) = A( I, J ) 00877 INDX = INDX + 1 00878 200 CONTINUE 00879 210 CONTINUE 00880 END IF 00881 * 00882 NTEST = NTEST + 1 00883 INDWRK = N*( N+1 ) / 2 + 1 00884 CALL CHPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, 00885 $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, 00886 $ LIWEDC, IINFO ) 00887 IF( IINFO.NE.0 ) THEN 00888 WRITE( NOUNIT, FMT = 9999 )'CHPEVD(V,' // UPLO // 00889 $ ')', IINFO, N, JTYPE, IOLDSD 00890 INFO = ABS( IINFO ) 00891 IF( IINFO.LT.0 ) THEN 00892 RETURN 00893 ELSE 00894 RESULT( NTEST ) = ULPINV 00895 RESULT( NTEST+1 ) = ULPINV 00896 RESULT( NTEST+2 ) = ULPINV 00897 GO TO 270 00898 END IF 00899 END IF 00900 * 00901 * Do tests 13 and 14. 00902 * 00903 CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, 00904 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 00905 * 00906 IF( IUPLO.EQ.1 ) THEN 00907 INDX = 1 00908 DO 230 J = 1, N 00909 DO 220 I = 1, J 00910 WORK( INDX ) = A( I, J ) 00911 INDX = INDX + 1 00912 220 CONTINUE 00913 230 CONTINUE 00914 ELSE 00915 INDX = 1 00916 DO 250 J = 1, N 00917 DO 240 I = J, N 00918 WORK( INDX ) = A( I, J ) 00919 INDX = INDX + 1 00920 240 CONTINUE 00921 250 CONTINUE 00922 END IF 00923 * 00924 NTEST = NTEST + 2 00925 INDWRK = N*( N+1 ) / 2 + 1 00926 CALL CHPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, 00927 $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, 00928 $ LIWEDC, IINFO ) 00929 IF( IINFO.NE.0 ) THEN 00930 WRITE( NOUNIT, FMT = 9999 )'CHPEVD(N,' // UPLO // 00931 $ ')', IINFO, N, JTYPE, IOLDSD 00932 INFO = ABS( IINFO ) 00933 IF( IINFO.LT.0 ) THEN 00934 RETURN 00935 ELSE 00936 RESULT( NTEST ) = ULPINV 00937 GO TO 270 00938 END IF 00939 END IF 00940 * 00941 * Do test 15. 00942 * 00943 TEMP1 = ZERO 00944 TEMP2 = ZERO 00945 DO 260 J = 1, N 00946 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) 00947 TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) 00948 260 CONTINUE 00949 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 00950 $ ULP*MAX( TEMP1, TEMP2 ) ) 00951 * 00952 * Load array WORK with the upper or lower triangular part 00953 * of the matrix in packed form. 00954 * 00955 270 CONTINUE 00956 IF( IUPLO.EQ.1 ) THEN 00957 INDX = 1 00958 DO 290 J = 1, N 00959 DO 280 I = 1, J 00960 WORK( INDX ) = A( I, J ) 00961 INDX = INDX + 1 00962 280 CONTINUE 00963 290 CONTINUE 00964 ELSE 00965 INDX = 1 00966 DO 310 J = 1, N 00967 DO 300 I = J, N 00968 WORK( INDX ) = A( I, J ) 00969 INDX = INDX + 1 00970 300 CONTINUE 00971 310 CONTINUE 00972 END IF 00973 * 00974 NTEST = NTEST + 1 00975 * 00976 IF( N.GT.0 ) THEN 00977 TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) 00978 IF( IL.NE.1 ) THEN 00979 VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), 00980 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00981 ELSE IF( N.GT.0 ) THEN 00982 VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), 00983 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00984 END IF 00985 IF( IU.NE.N ) THEN 00986 VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), 00987 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00988 ELSE IF( N.GT.0 ) THEN 00989 VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), 00990 $ TEN*ULP*TEMP3, TEN*RTUNFL ) 00991 END IF 00992 ELSE 00993 TEMP3 = ZERO 00994 VL = ZERO 00995 VU = ONE 00996 END IF 00997 * 00998 CALL CHPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, 00999 $ ABSTOL, M, WA1, Z, LDU, V, RWORK, IWORK, 01000 $ IWORK( 5*N+1 ), IINFO ) 01001 IF( IINFO.NE.0 ) THEN 01002 WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,A,' // UPLO // 01003 $ ')', IINFO, N, JTYPE, IOLDSD 01004 INFO = ABS( IINFO ) 01005 IF( IINFO.LT.0 ) THEN 01006 RETURN 01007 ELSE 01008 RESULT( NTEST ) = ULPINV 01009 RESULT( NTEST+1 ) = ULPINV 01010 RESULT( NTEST+2 ) = ULPINV 01011 GO TO 370 01012 END IF 01013 END IF 01014 * 01015 * Do tests 16 and 17. 01016 * 01017 CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, 01018 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01019 * 01020 NTEST = NTEST + 2 01021 * 01022 IF( IUPLO.EQ.1 ) THEN 01023 INDX = 1 01024 DO 330 J = 1, N 01025 DO 320 I = 1, J 01026 WORK( INDX ) = A( I, J ) 01027 INDX = INDX + 1 01028 320 CONTINUE 01029 330 CONTINUE 01030 ELSE 01031 INDX = 1 01032 DO 350 J = 1, N 01033 DO 340 I = J, N 01034 WORK( INDX ) = A( I, J ) 01035 INDX = INDX + 1 01036 340 CONTINUE 01037 350 CONTINUE 01038 END IF 01039 * 01040 CALL CHPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, 01041 $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, 01042 $ IWORK( 5*N+1 ), IINFO ) 01043 IF( IINFO.NE.0 ) THEN 01044 WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,A,' // UPLO // 01045 $ ')', IINFO, N, JTYPE, IOLDSD 01046 INFO = ABS( IINFO ) 01047 IF( IINFO.LT.0 ) THEN 01048 RETURN 01049 ELSE 01050 RESULT( NTEST ) = ULPINV 01051 GO TO 370 01052 END IF 01053 END IF 01054 * 01055 * Do test 18. 01056 * 01057 TEMP1 = ZERO 01058 TEMP2 = ZERO 01059 DO 360 J = 1, N 01060 TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) 01061 TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) 01062 360 CONTINUE 01063 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 01064 $ ULP*MAX( TEMP1, TEMP2 ) ) 01065 * 01066 370 CONTINUE 01067 NTEST = NTEST + 1 01068 IF( IUPLO.EQ.1 ) THEN 01069 INDX = 1 01070 DO 390 J = 1, N 01071 DO 380 I = 1, J 01072 WORK( INDX ) = A( I, J ) 01073 INDX = INDX + 1 01074 380 CONTINUE 01075 390 CONTINUE 01076 ELSE 01077 INDX = 1 01078 DO 410 J = 1, N 01079 DO 400 I = J, N 01080 WORK( INDX ) = A( I, J ) 01081 INDX = INDX + 1 01082 400 CONTINUE 01083 410 CONTINUE 01084 END IF 01085 * 01086 CALL CHPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, 01087 $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, 01088 $ IWORK( 5*N+1 ), IINFO ) 01089 IF( IINFO.NE.0 ) THEN 01090 WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,I,' // UPLO // 01091 $ ')', IINFO, N, JTYPE, IOLDSD 01092 INFO = ABS( IINFO ) 01093 IF( IINFO.LT.0 ) THEN 01094 RETURN 01095 ELSE 01096 RESULT( NTEST ) = ULPINV 01097 RESULT( NTEST+1 ) = ULPINV 01098 RESULT( NTEST+2 ) = ULPINV 01099 GO TO 460 01100 END IF 01101 END IF 01102 * 01103 * Do tests 19 and 20. 01104 * 01105 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 01106 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01107 * 01108 NTEST = NTEST + 2 01109 * 01110 IF( IUPLO.EQ.1 ) THEN 01111 INDX = 1 01112 DO 430 J = 1, N 01113 DO 420 I = 1, J 01114 WORK( INDX ) = A( I, J ) 01115 INDX = INDX + 1 01116 420 CONTINUE 01117 430 CONTINUE 01118 ELSE 01119 INDX = 1 01120 DO 450 J = 1, N 01121 DO 440 I = J, N 01122 WORK( INDX ) = A( I, J ) 01123 INDX = INDX + 1 01124 440 CONTINUE 01125 450 CONTINUE 01126 END IF 01127 * 01128 CALL CHPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, 01129 $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, 01130 $ IWORK( 5*N+1 ), IINFO ) 01131 IF( IINFO.NE.0 ) THEN 01132 WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,I,' // UPLO // 01133 $ ')', IINFO, N, JTYPE, IOLDSD 01134 INFO = ABS( IINFO ) 01135 IF( IINFO.LT.0 ) THEN 01136 RETURN 01137 ELSE 01138 RESULT( NTEST ) = ULPINV 01139 GO TO 460 01140 END IF 01141 END IF 01142 * 01143 * Do test 21. 01144 * 01145 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 01146 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 01147 IF( N.GT.0 ) THEN 01148 TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) 01149 ELSE 01150 TEMP3 = ZERO 01151 END IF 01152 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 01153 $ MAX( UNFL, TEMP3*ULP ) 01154 * 01155 460 CONTINUE 01156 NTEST = NTEST + 1 01157 IF( IUPLO.EQ.1 ) THEN 01158 INDX = 1 01159 DO 480 J = 1, N 01160 DO 470 I = 1, J 01161 WORK( INDX ) = A( I, J ) 01162 INDX = INDX + 1 01163 470 CONTINUE 01164 480 CONTINUE 01165 ELSE 01166 INDX = 1 01167 DO 500 J = 1, N 01168 DO 490 I = J, N 01169 WORK( INDX ) = A( I, J ) 01170 INDX = INDX + 1 01171 490 CONTINUE 01172 500 CONTINUE 01173 END IF 01174 * 01175 CALL CHPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, 01176 $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, 01177 $ IWORK( 5*N+1 ), IINFO ) 01178 IF( IINFO.NE.0 ) THEN 01179 WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,V,' // UPLO // 01180 $ ')', IINFO, N, JTYPE, IOLDSD 01181 INFO = ABS( IINFO ) 01182 IF( IINFO.LT.0 ) THEN 01183 RETURN 01184 ELSE 01185 RESULT( NTEST ) = ULPINV 01186 RESULT( NTEST+1 ) = ULPINV 01187 RESULT( NTEST+2 ) = ULPINV 01188 GO TO 550 01189 END IF 01190 END IF 01191 * 01192 * Do tests 22 and 23. 01193 * 01194 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 01195 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01196 * 01197 NTEST = NTEST + 2 01198 * 01199 IF( IUPLO.EQ.1 ) THEN 01200 INDX = 1 01201 DO 520 J = 1, N 01202 DO 510 I = 1, J 01203 WORK( INDX ) = A( I, J ) 01204 INDX = INDX + 1 01205 510 CONTINUE 01206 520 CONTINUE 01207 ELSE 01208 INDX = 1 01209 DO 540 J = 1, N 01210 DO 530 I = J, N 01211 WORK( INDX ) = A( I, J ) 01212 INDX = INDX + 1 01213 530 CONTINUE 01214 540 CONTINUE 01215 END IF 01216 * 01217 CALL CHPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, 01218 $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, 01219 $ IWORK( 5*N+1 ), IINFO ) 01220 IF( IINFO.NE.0 ) THEN 01221 WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,V,' // UPLO // 01222 $ ')', IINFO, N, JTYPE, IOLDSD 01223 INFO = ABS( IINFO ) 01224 IF( IINFO.LT.0 ) THEN 01225 RETURN 01226 ELSE 01227 RESULT( NTEST ) = ULPINV 01228 GO TO 550 01229 END IF 01230 END IF 01231 * 01232 IF( M3.EQ.0 .AND. N.GT.0 ) THEN 01233 RESULT( NTEST ) = ULPINV 01234 GO TO 550 01235 END IF 01236 * 01237 * Do test 24. 01238 * 01239 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 01240 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 01241 IF( N.GT.0 ) THEN 01242 TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) 01243 ELSE 01244 TEMP3 = ZERO 01245 END IF 01246 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 01247 $ MAX( UNFL, TEMP3*ULP ) 01248 * 01249 550 CONTINUE 01250 * 01251 * Call CHBEVD and CHBEVX. 01252 * 01253 IF( JTYPE.LE.7 ) THEN 01254 KD = 0 01255 ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN 01256 KD = MAX( N-1, 0 ) 01257 ELSE 01258 KD = IHBW 01259 END IF 01260 * 01261 * Load array V with the upper or lower triangular part 01262 * of the matrix in band form. 01263 * 01264 IF( IUPLO.EQ.1 ) THEN 01265 DO 570 J = 1, N 01266 DO 560 I = MAX( 1, J-KD ), J 01267 V( KD+1+I-J, J ) = A( I, J ) 01268 560 CONTINUE 01269 570 CONTINUE 01270 ELSE 01271 DO 590 J = 1, N 01272 DO 580 I = J, MIN( N, J+KD ) 01273 V( 1+I-J, J ) = A( I, J ) 01274 580 CONTINUE 01275 590 CONTINUE 01276 END IF 01277 * 01278 NTEST = NTEST + 1 01279 CALL CHBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, 01280 $ LWEDC, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) 01281 IF( IINFO.NE.0 ) THEN 01282 WRITE( NOUNIT, FMT = 9998 )'CHBEVD(V,' // UPLO // 01283 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01284 INFO = ABS( IINFO ) 01285 IF( IINFO.LT.0 ) THEN 01286 RETURN 01287 ELSE 01288 RESULT( NTEST ) = ULPINV 01289 RESULT( NTEST+1 ) = ULPINV 01290 RESULT( NTEST+2 ) = ULPINV 01291 GO TO 650 01292 END IF 01293 END IF 01294 * 01295 * Do tests 25 and 26. 01296 * 01297 CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, 01298 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01299 * 01300 IF( IUPLO.EQ.1 ) THEN 01301 DO 610 J = 1, N 01302 DO 600 I = MAX( 1, J-KD ), J 01303 V( KD+1+I-J, J ) = A( I, J ) 01304 600 CONTINUE 01305 610 CONTINUE 01306 ELSE 01307 DO 630 J = 1, N 01308 DO 620 I = J, MIN( N, J+KD ) 01309 V( 1+I-J, J ) = A( I, J ) 01310 620 CONTINUE 01311 630 CONTINUE 01312 END IF 01313 * 01314 NTEST = NTEST + 2 01315 CALL CHBEVD( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK, 01316 $ LWEDC, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) 01317 IF( IINFO.NE.0 ) THEN 01318 WRITE( NOUNIT, FMT = 9998 )'CHBEVD(N,' // UPLO // 01319 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01320 INFO = ABS( IINFO ) 01321 IF( IINFO.LT.0 ) THEN 01322 RETURN 01323 ELSE 01324 RESULT( NTEST ) = ULPINV 01325 GO TO 650 01326 END IF 01327 END IF 01328 * 01329 * Do test 27. 01330 * 01331 TEMP1 = ZERO 01332 TEMP2 = ZERO 01333 DO 640 J = 1, N 01334 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) 01335 TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) 01336 640 CONTINUE 01337 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 01338 $ ULP*MAX( TEMP1, TEMP2 ) ) 01339 * 01340 * Load array V with the upper or lower triangular part 01341 * of the matrix in band form. 01342 * 01343 650 CONTINUE 01344 IF( IUPLO.EQ.1 ) THEN 01345 DO 670 J = 1, N 01346 DO 660 I = MAX( 1, J-KD ), J 01347 V( KD+1+I-J, J ) = A( I, J ) 01348 660 CONTINUE 01349 670 CONTINUE 01350 ELSE 01351 DO 690 J = 1, N 01352 DO 680 I = J, MIN( N, J+KD ) 01353 V( 1+I-J, J ) = A( I, J ) 01354 680 CONTINUE 01355 690 CONTINUE 01356 END IF 01357 * 01358 NTEST = NTEST + 1 01359 CALL CHBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, 01360 $ VU, IL, IU, ABSTOL, M, WA1, Z, LDU, WORK, 01361 $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) 01362 IF( IINFO.NE.0 ) THEN 01363 WRITE( NOUNIT, FMT = 9999 )'CHBEVX(V,A,' // UPLO // 01364 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01365 INFO = ABS( IINFO ) 01366 IF( IINFO.LT.0 ) THEN 01367 RETURN 01368 ELSE 01369 RESULT( NTEST ) = ULPINV 01370 RESULT( NTEST+1 ) = ULPINV 01371 RESULT( NTEST+2 ) = ULPINV 01372 GO TO 750 01373 END IF 01374 END IF 01375 * 01376 * Do tests 28 and 29. 01377 * 01378 CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, 01379 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01380 * 01381 NTEST = NTEST + 2 01382 * 01383 IF( IUPLO.EQ.1 ) THEN 01384 DO 710 J = 1, N 01385 DO 700 I = MAX( 1, J-KD ), J 01386 V( KD+1+I-J, J ) = A( I, J ) 01387 700 CONTINUE 01388 710 CONTINUE 01389 ELSE 01390 DO 730 J = 1, N 01391 DO 720 I = J, MIN( N, J+KD ) 01392 V( 1+I-J, J ) = A( I, J ) 01393 720 CONTINUE 01394 730 CONTINUE 01395 END IF 01396 * 01397 CALL CHBEVX( 'N', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, 01398 $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, 01399 $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) 01400 IF( IINFO.NE.0 ) THEN 01401 WRITE( NOUNIT, FMT = 9998 )'CHBEVX(N,A,' // UPLO // 01402 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01403 INFO = ABS( IINFO ) 01404 IF( IINFO.LT.0 ) THEN 01405 RETURN 01406 ELSE 01407 RESULT( NTEST ) = ULPINV 01408 GO TO 750 01409 END IF 01410 END IF 01411 * 01412 * Do test 30. 01413 * 01414 TEMP1 = ZERO 01415 TEMP2 = ZERO 01416 DO 740 J = 1, N 01417 TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) 01418 TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) 01419 740 CONTINUE 01420 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 01421 $ ULP*MAX( TEMP1, TEMP2 ) ) 01422 * 01423 * Load array V with the upper or lower triangular part 01424 * of the matrix in band form. 01425 * 01426 750 CONTINUE 01427 NTEST = NTEST + 1 01428 IF( IUPLO.EQ.1 ) THEN 01429 DO 770 J = 1, N 01430 DO 760 I = MAX( 1, J-KD ), J 01431 V( KD+1+I-J, J ) = A( I, J ) 01432 760 CONTINUE 01433 770 CONTINUE 01434 ELSE 01435 DO 790 J = 1, N 01436 DO 780 I = J, MIN( N, J+KD ) 01437 V( 1+I-J, J ) = A( I, J ) 01438 780 CONTINUE 01439 790 CONTINUE 01440 END IF 01441 * 01442 CALL CHBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, 01443 $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, 01444 $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) 01445 IF( IINFO.NE.0 ) THEN 01446 WRITE( NOUNIT, FMT = 9998 )'CHBEVX(V,I,' // UPLO // 01447 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01448 INFO = ABS( IINFO ) 01449 IF( IINFO.LT.0 ) THEN 01450 RETURN 01451 ELSE 01452 RESULT( NTEST ) = ULPINV 01453 RESULT( NTEST+1 ) = ULPINV 01454 RESULT( NTEST+2 ) = ULPINV 01455 GO TO 840 01456 END IF 01457 END IF 01458 * 01459 * Do tests 31 and 32. 01460 * 01461 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 01462 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01463 * 01464 NTEST = NTEST + 2 01465 * 01466 IF( IUPLO.EQ.1 ) THEN 01467 DO 810 J = 1, N 01468 DO 800 I = MAX( 1, J-KD ), J 01469 V( KD+1+I-J, J ) = A( I, J ) 01470 800 CONTINUE 01471 810 CONTINUE 01472 ELSE 01473 DO 830 J = 1, N 01474 DO 820 I = J, MIN( N, J+KD ) 01475 V( 1+I-J, J ) = A( I, J ) 01476 820 CONTINUE 01477 830 CONTINUE 01478 END IF 01479 CALL CHBEVX( 'N', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, 01480 $ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, 01481 $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) 01482 IF( IINFO.NE.0 ) THEN 01483 WRITE( NOUNIT, FMT = 9998 )'CHBEVX(N,I,' // UPLO // 01484 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01485 INFO = ABS( IINFO ) 01486 IF( IINFO.LT.0 ) THEN 01487 RETURN 01488 ELSE 01489 RESULT( NTEST ) = ULPINV 01490 GO TO 840 01491 END IF 01492 END IF 01493 * 01494 * Do test 33. 01495 * 01496 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 01497 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 01498 IF( N.GT.0 ) THEN 01499 TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) 01500 ELSE 01501 TEMP3 = ZERO 01502 END IF 01503 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 01504 $ MAX( UNFL, TEMP3*ULP ) 01505 * 01506 * Load array V with the upper or lower triangular part 01507 * of the matrix in band form. 01508 * 01509 840 CONTINUE 01510 NTEST = NTEST + 1 01511 IF( IUPLO.EQ.1 ) THEN 01512 DO 860 J = 1, N 01513 DO 850 I = MAX( 1, J-KD ), J 01514 V( KD+1+I-J, J ) = A( I, J ) 01515 850 CONTINUE 01516 860 CONTINUE 01517 ELSE 01518 DO 880 J = 1, N 01519 DO 870 I = J, MIN( N, J+KD ) 01520 V( 1+I-J, J ) = A( I, J ) 01521 870 CONTINUE 01522 880 CONTINUE 01523 END IF 01524 CALL CHBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, 01525 $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, 01526 $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) 01527 IF( IINFO.NE.0 ) THEN 01528 WRITE( NOUNIT, FMT = 9998 )'CHBEVX(V,V,' // UPLO // 01529 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01530 INFO = ABS( IINFO ) 01531 IF( IINFO.LT.0 ) THEN 01532 RETURN 01533 ELSE 01534 RESULT( NTEST ) = ULPINV 01535 RESULT( NTEST+1 ) = ULPINV 01536 RESULT( NTEST+2 ) = ULPINV 01537 GO TO 930 01538 END IF 01539 END IF 01540 * 01541 * Do tests 34 and 35. 01542 * 01543 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 01544 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01545 * 01546 NTEST = NTEST + 2 01547 * 01548 IF( IUPLO.EQ.1 ) THEN 01549 DO 900 J = 1, N 01550 DO 890 I = MAX( 1, J-KD ), J 01551 V( KD+1+I-J, J ) = A( I, J ) 01552 890 CONTINUE 01553 900 CONTINUE 01554 ELSE 01555 DO 920 J = 1, N 01556 DO 910 I = J, MIN( N, J+KD ) 01557 V( 1+I-J, J ) = A( I, J ) 01558 910 CONTINUE 01559 920 CONTINUE 01560 END IF 01561 CALL CHBEVX( 'N', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, 01562 $ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, 01563 $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) 01564 IF( IINFO.NE.0 ) THEN 01565 WRITE( NOUNIT, FMT = 9998 )'CHBEVX(N,V,' // UPLO // 01566 $ ')', IINFO, N, KD, JTYPE, IOLDSD 01567 INFO = ABS( IINFO ) 01568 IF( IINFO.LT.0 ) THEN 01569 RETURN 01570 ELSE 01571 RESULT( NTEST ) = ULPINV 01572 GO TO 930 01573 END IF 01574 END IF 01575 * 01576 IF( M3.EQ.0 .AND. N.GT.0 ) THEN 01577 RESULT( NTEST ) = ULPINV 01578 GO TO 930 01579 END IF 01580 * 01581 * Do test 36. 01582 * 01583 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 01584 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 01585 IF( N.GT.0 ) THEN 01586 TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) 01587 ELSE 01588 TEMP3 = ZERO 01589 END IF 01590 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 01591 $ MAX( UNFL, TEMP3*ULP ) 01592 * 01593 930 CONTINUE 01594 * 01595 * Call CHEEV 01596 * 01597 CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) 01598 * 01599 NTEST = NTEST + 1 01600 CALL CHEEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, RWORK, 01601 $ IINFO ) 01602 IF( IINFO.NE.0 ) THEN 01603 WRITE( NOUNIT, FMT = 9999 )'CHEEV(V,' // UPLO // ')', 01604 $ IINFO, N, JTYPE, IOLDSD 01605 INFO = ABS( IINFO ) 01606 IF( IINFO.LT.0 ) THEN 01607 RETURN 01608 ELSE 01609 RESULT( NTEST ) = ULPINV 01610 RESULT( NTEST+1 ) = ULPINV 01611 RESULT( NTEST+2 ) = ULPINV 01612 GO TO 950 01613 END IF 01614 END IF 01615 * 01616 * Do tests 37 and 38 01617 * 01618 CALL CHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, 01619 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01620 * 01621 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01622 * 01623 NTEST = NTEST + 2 01624 CALL CHEEV( 'N', UPLO, N, A, LDU, D3, WORK, LWORK, RWORK, 01625 $ IINFO ) 01626 IF( IINFO.NE.0 ) THEN 01627 WRITE( NOUNIT, FMT = 9999 )'CHEEV(N,' // UPLO // ')', 01628 $ IINFO, N, JTYPE, IOLDSD 01629 INFO = ABS( IINFO ) 01630 IF( IINFO.LT.0 ) THEN 01631 RETURN 01632 ELSE 01633 RESULT( NTEST ) = ULPINV 01634 GO TO 950 01635 END IF 01636 END IF 01637 * 01638 * Do test 39 01639 * 01640 TEMP1 = ZERO 01641 TEMP2 = ZERO 01642 DO 940 J = 1, N 01643 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) 01644 TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) 01645 940 CONTINUE 01646 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 01647 $ ULP*MAX( TEMP1, TEMP2 ) ) 01648 * 01649 950 CONTINUE 01650 * 01651 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01652 * 01653 * Call CHPEV 01654 * 01655 * Load array WORK with the upper or lower triangular 01656 * part of the matrix in packed form. 01657 * 01658 IF( IUPLO.EQ.1 ) THEN 01659 INDX = 1 01660 DO 970 J = 1, N 01661 DO 960 I = 1, J 01662 WORK( INDX ) = A( I, J ) 01663 INDX = INDX + 1 01664 960 CONTINUE 01665 970 CONTINUE 01666 ELSE 01667 INDX = 1 01668 DO 990 J = 1, N 01669 DO 980 I = J, N 01670 WORK( INDX ) = A( I, J ) 01671 INDX = INDX + 1 01672 980 CONTINUE 01673 990 CONTINUE 01674 END IF 01675 * 01676 NTEST = NTEST + 1 01677 INDWRK = N*( N+1 ) / 2 + 1 01678 CALL CHPEV( 'V', UPLO, N, WORK, D1, Z, LDU, 01679 $ WORK( INDWRK ), RWORK, IINFO ) 01680 IF( IINFO.NE.0 ) THEN 01681 WRITE( NOUNIT, FMT = 9999 )'CHPEV(V,' // UPLO // ')', 01682 $ IINFO, N, JTYPE, IOLDSD 01683 INFO = ABS( IINFO ) 01684 IF( IINFO.LT.0 ) THEN 01685 RETURN 01686 ELSE 01687 RESULT( NTEST ) = ULPINV 01688 RESULT( NTEST+1 ) = ULPINV 01689 RESULT( NTEST+2 ) = ULPINV 01690 GO TO 1050 01691 END IF 01692 END IF 01693 * 01694 * Do tests 40 and 41. 01695 * 01696 CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, 01697 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01698 * 01699 IF( IUPLO.EQ.1 ) THEN 01700 INDX = 1 01701 DO 1010 J = 1, N 01702 DO 1000 I = 1, J 01703 WORK( INDX ) = A( I, J ) 01704 INDX = INDX + 1 01705 1000 CONTINUE 01706 1010 CONTINUE 01707 ELSE 01708 INDX = 1 01709 DO 1030 J = 1, N 01710 DO 1020 I = J, N 01711 WORK( INDX ) = A( I, J ) 01712 INDX = INDX + 1 01713 1020 CONTINUE 01714 1030 CONTINUE 01715 END IF 01716 * 01717 NTEST = NTEST + 2 01718 INDWRK = N*( N+1 ) / 2 + 1 01719 CALL CHPEV( 'N', UPLO, N, WORK, D3, Z, LDU, 01720 $ WORK( INDWRK ), RWORK, IINFO ) 01721 IF( IINFO.NE.0 ) THEN 01722 WRITE( NOUNIT, FMT = 9999 )'CHPEV(N,' // UPLO // ')', 01723 $ IINFO, N, JTYPE, IOLDSD 01724 INFO = ABS( IINFO ) 01725 IF( IINFO.LT.0 ) THEN 01726 RETURN 01727 ELSE 01728 RESULT( NTEST ) = ULPINV 01729 GO TO 1050 01730 END IF 01731 END IF 01732 * 01733 * Do test 42 01734 * 01735 TEMP1 = ZERO 01736 TEMP2 = ZERO 01737 DO 1040 J = 1, N 01738 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) 01739 TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) 01740 1040 CONTINUE 01741 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 01742 $ ULP*MAX( TEMP1, TEMP2 ) ) 01743 * 01744 1050 CONTINUE 01745 * 01746 * Call CHBEV 01747 * 01748 IF( JTYPE.LE.7 ) THEN 01749 KD = 0 01750 ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN 01751 KD = MAX( N-1, 0 ) 01752 ELSE 01753 KD = IHBW 01754 END IF 01755 * 01756 * Load array V with the upper or lower triangular part 01757 * of the matrix in band form. 01758 * 01759 IF( IUPLO.EQ.1 ) THEN 01760 DO 1070 J = 1, N 01761 DO 1060 I = MAX( 1, J-KD ), J 01762 V( KD+1+I-J, J ) = A( I, J ) 01763 1060 CONTINUE 01764 1070 CONTINUE 01765 ELSE 01766 DO 1090 J = 1, N 01767 DO 1080 I = J, MIN( N, J+KD ) 01768 V( 1+I-J, J ) = A( I, J ) 01769 1080 CONTINUE 01770 1090 CONTINUE 01771 END IF 01772 * 01773 NTEST = NTEST + 1 01774 CALL CHBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, 01775 $ RWORK, IINFO ) 01776 IF( IINFO.NE.0 ) THEN 01777 WRITE( NOUNIT, FMT = 9998 )'CHBEV(V,' // UPLO // ')', 01778 $ IINFO, N, KD, JTYPE, IOLDSD 01779 INFO = ABS( IINFO ) 01780 IF( IINFO.LT.0 ) THEN 01781 RETURN 01782 ELSE 01783 RESULT( NTEST ) = ULPINV 01784 RESULT( NTEST+1 ) = ULPINV 01785 RESULT( NTEST+2 ) = ULPINV 01786 GO TO 1140 01787 END IF 01788 END IF 01789 * 01790 * Do tests 43 and 44. 01791 * 01792 CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, 01793 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01794 * 01795 IF( IUPLO.EQ.1 ) THEN 01796 DO 1110 J = 1, N 01797 DO 1100 I = MAX( 1, J-KD ), J 01798 V( KD+1+I-J, J ) = A( I, J ) 01799 1100 CONTINUE 01800 1110 CONTINUE 01801 ELSE 01802 DO 1130 J = 1, N 01803 DO 1120 I = J, MIN( N, J+KD ) 01804 V( 1+I-J, J ) = A( I, J ) 01805 1120 CONTINUE 01806 1130 CONTINUE 01807 END IF 01808 * 01809 NTEST = NTEST + 2 01810 CALL CHBEV( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK, 01811 $ RWORK, IINFO ) 01812 IF( IINFO.NE.0 ) THEN 01813 WRITE( NOUNIT, FMT = 9998 )'CHBEV(N,' // UPLO // ')', 01814 $ IINFO, N, KD, JTYPE, IOLDSD 01815 INFO = ABS( IINFO ) 01816 IF( IINFO.LT.0 ) THEN 01817 RETURN 01818 ELSE 01819 RESULT( NTEST ) = ULPINV 01820 GO TO 1140 01821 END IF 01822 END IF 01823 * 01824 1140 CONTINUE 01825 * 01826 * Do test 45. 01827 * 01828 TEMP1 = ZERO 01829 TEMP2 = ZERO 01830 DO 1150 J = 1, N 01831 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) 01832 TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) 01833 1150 CONTINUE 01834 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 01835 $ ULP*MAX( TEMP1, TEMP2 ) ) 01836 * 01837 CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) 01838 NTEST = NTEST + 1 01839 CALL CHEEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, 01840 $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, 01841 $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, 01842 $ IINFO ) 01843 IF( IINFO.NE.0 ) THEN 01844 WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,A,' // UPLO // 01845 $ ')', IINFO, N, JTYPE, IOLDSD 01846 INFO = ABS( IINFO ) 01847 IF( IINFO.LT.0 ) THEN 01848 RETURN 01849 ELSE 01850 RESULT( NTEST ) = ULPINV 01851 RESULT( NTEST+1 ) = ULPINV 01852 RESULT( NTEST+2 ) = ULPINV 01853 GO TO 1170 01854 END IF 01855 END IF 01856 * 01857 * Do tests 45 and 46 (or ... ) 01858 * 01859 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01860 * 01861 CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, 01862 $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01863 * 01864 NTEST = NTEST + 2 01865 CALL CHEEVR( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, 01866 $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, 01867 $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, 01868 $ IINFO ) 01869 IF( IINFO.NE.0 ) THEN 01870 WRITE( NOUNIT, FMT = 9999 )'CHEEVR(N,A,' // UPLO // 01871 $ ')', IINFO, N, JTYPE, IOLDSD 01872 INFO = ABS( IINFO ) 01873 IF( IINFO.LT.0 ) THEN 01874 RETURN 01875 ELSE 01876 RESULT( NTEST ) = ULPINV 01877 GO TO 1170 01878 END IF 01879 END IF 01880 * 01881 * Do test 47 (or ... ) 01882 * 01883 TEMP1 = ZERO 01884 TEMP2 = ZERO 01885 DO 1160 J = 1, N 01886 TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) 01887 TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) 01888 1160 CONTINUE 01889 RESULT( NTEST ) = TEMP2 / MAX( UNFL, 01890 $ ULP*MAX( TEMP1, TEMP2 ) ) 01891 * 01892 1170 CONTINUE 01893 * 01894 NTEST = NTEST + 1 01895 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01896 CALL CHEEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, 01897 $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, 01898 $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, 01899 $ IINFO ) 01900 IF( IINFO.NE.0 ) THEN 01901 WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,I,' // UPLO // 01902 $ ')', IINFO, N, JTYPE, IOLDSD 01903 INFO = ABS( IINFO ) 01904 IF( IINFO.LT.0 ) THEN 01905 RETURN 01906 ELSE 01907 RESULT( NTEST ) = ULPINV 01908 RESULT( NTEST+1 ) = ULPINV 01909 RESULT( NTEST+2 ) = ULPINV 01910 GO TO 1180 01911 END IF 01912 END IF 01913 * 01914 * Do tests 48 and 49 (or +??) 01915 * 01916 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01917 * 01918 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 01919 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01920 * 01921 NTEST = NTEST + 2 01922 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01923 CALL CHEEVR( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, 01924 $ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK, 01925 $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, 01926 $ IINFO ) 01927 IF( IINFO.NE.0 ) THEN 01928 WRITE( NOUNIT, FMT = 9999 )'CHEEVR(N,I,' // UPLO // 01929 $ ')', IINFO, N, JTYPE, IOLDSD 01930 INFO = ABS( IINFO ) 01931 IF( IINFO.LT.0 ) THEN 01932 RETURN 01933 ELSE 01934 RESULT( NTEST ) = ULPINV 01935 GO TO 1180 01936 END IF 01937 END IF 01938 * 01939 * Do test 50 (or +??) 01940 * 01941 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 01942 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 01943 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 01944 $ MAX( UNFL, ULP*TEMP3 ) 01945 1180 CONTINUE 01946 * 01947 NTEST = NTEST + 1 01948 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01949 CALL CHEEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, 01950 $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, 01951 $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, 01952 $ IINFO ) 01953 IF( IINFO.NE.0 ) THEN 01954 WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,V,' // UPLO // 01955 $ ')', IINFO, N, JTYPE, IOLDSD 01956 INFO = ABS( IINFO ) 01957 IF( IINFO.LT.0 ) THEN 01958 RETURN 01959 ELSE 01960 RESULT( NTEST ) = ULPINV 01961 RESULT( NTEST+1 ) = ULPINV 01962 RESULT( NTEST+2 ) = ULPINV 01963 GO TO 1190 01964 END IF 01965 END IF 01966 * 01967 * Do tests 51 and 52 (or +??) 01968 * 01969 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01970 * 01971 CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, 01972 $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) 01973 * 01974 NTEST = NTEST + 2 01975 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 01976 CALL CHEEVR( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, 01977 $ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK, 01978 $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, 01979 $ IINFO ) 01980 IF( IINFO.NE.0 ) THEN 01981 WRITE( NOUNIT, FMT = 9999 )'CHEEVR(N,V,' // UPLO // 01982 $ ')', IINFO, N, JTYPE, IOLDSD 01983 INFO = ABS( IINFO ) 01984 IF( IINFO.LT.0 ) THEN 01985 RETURN 01986 ELSE 01987 RESULT( NTEST ) = ULPINV 01988 GO TO 1190 01989 END IF 01990 END IF 01991 * 01992 IF( M3.EQ.0 .AND. N.GT.0 ) THEN 01993 RESULT( NTEST ) = ULPINV 01994 GO TO 1190 01995 END IF 01996 * 01997 * Do test 52 (or +??) 01998 * 01999 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 02000 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 02001 IF( N.GT.0 ) THEN 02002 TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) 02003 ELSE 02004 TEMP3 = ZERO 02005 END IF 02006 RESULT( NTEST ) = ( TEMP1+TEMP2 ) / 02007 $ MAX( UNFL, TEMP3*ULP ) 02008 * 02009 CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) 02010 * 02011 * 02012 * 02013 * 02014 * Load array V with the upper or lower triangular part 02015 * of the matrix in band form. 02016 * 02017 1190 CONTINUE 02018 * 02019 1200 CONTINUE 02020 * 02021 * End of Loop -- Check for RESULT(j) > THRESH 02022 * 02023 NTESTT = NTESTT + NTEST 02024 CALL SLAFTS( 'CST', N, N, JTYPE, NTEST, RESULT, IOLDSD, 02025 $ THRESH, NOUNIT, NERRS ) 02026 * 02027 1210 CONTINUE 02028 1220 CONTINUE 02029 * 02030 * Summary 02031 * 02032 CALL ALASVM( 'CST', NOUNIT, NERRS, NTESTT, 0 ) 02033 * 02034 9999 FORMAT( ' CDRVST: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, 02035 $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) 02036 9998 FORMAT( ' CDRVST: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, 02037 $ ', KD=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, 02038 $ ')' ) 02039 * 02040 RETURN 02041 * 02042 * End of CDRVST 02043 * 02044 END
1.7.3 
