|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 PROGRAM MAIN 00002 * 00003 * -- LAPACK test routine (version 3.2) -- 00004 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00005 * November 2006 00006 * 00007 * .. External Functions .. 00008 INTEGER ILAENV 00009 EXTERNAL ILAENV 00010 * .. 00011 * .. Local Scalars .. 00012 INTEGER IEEEOK 00013 * .. 00014 * .. Executable Statements .. 00015 * 00016 WRITE( 6, FMT = * ) 00017 $ 'We are about to check whether infinity arithmetic' 00018 WRITE( 6, FMT = * )'can be trusted. If this test hangs, set' 00019 WRITE( 6, FMT = * ) 00020 $ 'ILAENV = 0 for ISPEC = 10 in LAPACK/SRC/ilaenv.f' 00021 * 00022 IEEEOK = ILAENV( 10, 'ILAENV', 'N', 1, 2, 3, 4 ) 00023 WRITE( 6, FMT = * ) 00024 * 00025 IF( IEEEOK.EQ.0 ) THEN 00026 WRITE( 6, FMT = * ) 00027 $ 'Infinity arithmetic did not perform per the ieee spec' 00028 ELSE 00029 WRITE( 6, FMT = * ) 00030 $ 'Infinity arithmetic performed as per the ieee spec.' 00031 WRITE( 6, FMT = * ) 00032 $ 'However, this is not an exhaustive test and does not' 00033 WRITE( 6, FMT = * ) 00034 $ 'guarantee that infinity arithmetic meets the', 00035 $ ' ieee spec.' 00036 END IF 00037 * 00038 WRITE( 6, FMT = * ) 00039 WRITE( 6, FMT = * ) 00040 $ 'We are about to check whether NaN arithmetic' 00041 WRITE( 6, FMT = * )'can be trusted. If this test hangs, set' 00042 WRITE( 6, FMT = * ) 00043 $ 'ILAENV = 0 for ISPEC = 11 in LAPACK/SRC/ilaenv.f' 00044 IEEEOK = ILAENV( 11, 'ILAENV', 'N', 1, 2, 3, 4 ) 00045 * 00046 WRITE( 6, FMT = * ) 00047 IF( IEEEOK.EQ.0 ) THEN 00048 WRITE( 6, FMT = * ) 00049 $ 'NaN arithmetic did not perform per the ieee spec' 00050 ELSE 00051 WRITE( 6, FMT = * )'NaN arithmetic performed as per the ieee', 00052 $ ' spec.' 00053 WRITE( 6, FMT = * ) 00054 $ 'However, this is not an exhaustive test and does not' 00055 WRITE( 6, FMT = * )'guarantee that NaN arithmetic meets the', 00056 $ ' ieee spec.' 00057 END IF 00058 WRITE( 6, FMT = * ) 00059 * 00060 END 00061 INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, 00062 $ N4 ) 00063 * 00064 * -- LAPACK auxiliary routine (version 3.2) -- 00065 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00066 * November 2006 00067 * 00068 * .. Scalar Arguments .. 00069 CHARACTER*( * ) NAME, OPTS 00070 INTEGER ISPEC, N1, N2, N3, N4 00071 * .. 00072 * 00073 * Purpose 00074 * ======= 00075 * 00076 * ILAENV is called from the LAPACK routines to choose problem-dependent 00077 * parameters for the local environment. See ISPEC for a description of 00078 * the parameters. 00079 * 00080 * This version provides a set of parameters which should give good, 00081 * but not optimal, performance on many of the currently available 00082 * computers. Users are encouraged to modify this subroutine to set 00083 * the tuning parameters for their particular machine using the option 00084 * and problem size information in the arguments. 00085 * 00086 * This routine will not function correctly if it is converted to all 00087 * lower case. Converting it to all upper case is allowed. 00088 * 00089 * Arguments 00090 * ========= 00091 * 00092 * ISPEC (input) INTEGER 00093 * Specifies the parameter to be returned as the value of 00094 * ILAENV. 00095 * = 1: the optimal blocksize; if this value is 1, an unblocked 00096 * algorithm will give the best performance. 00097 * = 2: the minimum block size for which the block routine 00098 * should be used; if the usable block size is less than 00099 * this value, an unblocked routine should be used. 00100 * = 3: the crossover point (in a block routine, for N less 00101 * than this value, an unblocked routine should be used) 00102 * = 4: the number of shifts, used in the nonsymmetric 00103 * eigenvalue routines 00104 * = 5: the minimum column dimension for blocking to be used; 00105 * rectangular blocks must have dimension at least k by m, 00106 * where k is given by ILAENV(2,...) and m by ILAENV(5,...) 00107 * = 6: the crossover point for the SVD (when reducing an m by n 00108 * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds 00109 * this value, a QR factorization is used first to reduce 00110 * the matrix to a triangular form.) 00111 * = 7: the number of processors 00112 * = 8: the crossover point for the multishift QR and QZ methods 00113 * for nonsymmetric eigenvalue problems. 00114 * = 9: maximum size of the subproblems at the bottom of the 00115 * computation tree in the divide-and-conquer algorithm 00116 * (used by xGELSD and xGESDD) 00117 * =10: ieee NaN arithmetic can be trusted not to trap 00118 * =11: infinity arithmetic can be trusted not to trap 00119 * 00120 * NAME (input) CHARACTER*(*) 00121 * The name of the calling subroutine, in either upper case or 00122 * lower case. 00123 * 00124 * OPTS (input) CHARACTER*(*) 00125 * The character options to the subroutine NAME, concatenated 00126 * into a single character string. For example, UPLO = 'U', 00127 * TRANS = 'T', and DIAG = 'N' for a triangular routine would 00128 * be specified as OPTS = 'UTN'. 00129 * 00130 * N1 (input) INTEGER 00131 * N2 (input) INTEGER 00132 * N3 (input) INTEGER 00133 * N4 (input) INTEGER 00134 * Problem dimensions for the subroutine NAME; these may not all 00135 * be required. 00136 * 00137 * (ILAENV) (output) INTEGER 00138 * >= 0: the value of the parameter specified by ISPEC 00139 * < 0: if ILAENV = -k, the k-th argument had an illegal value. 00140 * 00141 * Further Details 00142 * =============== 00143 * 00144 * The following conventions have been used when calling ILAENV from the 00145 * LAPACK routines: 00146 * 1) OPTS is a concatenation of all of the character options to 00147 * subroutine NAME, in the same order that they appear in the 00148 * argument list for NAME, even if they are not used in determining 00149 * the value of the parameter specified by ISPEC. 00150 * 2) The problem dimensions N1, N2, N3, N4 are specified in the order 00151 * that they appear in the argument list for NAME. N1 is used 00152 * first, N2 second, and so on, and unused problem dimensions are 00153 * passed a value of -1. 00154 * 3) The parameter value returned by ILAENV is checked for validity in 00155 * the calling subroutine. For example, ILAENV is used to retrieve 00156 * the optimal blocksize for STRTRI as follows: 00157 * 00158 * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) 00159 * IF( NB.LE.1 ) NB = MAX( 1, N ) 00160 * 00161 * ===================================================================== 00162 * 00163 * .. Local Scalars .. 00164 LOGICAL CNAME, SNAME 00165 CHARACTER*1 C1 00166 CHARACTER*2 C2, C4 00167 CHARACTER*3 C3 00168 CHARACTER*6 SUBNAM 00169 INTEGER I, IC, IZ, NB, NBMIN, NX 00170 * .. 00171 * .. Intrinsic Functions .. 00172 INTRINSIC CHAR, ICHAR, INT, MIN, REAL 00173 * .. 00174 * .. External Functions .. 00175 INTEGER IEEECK 00176 EXTERNAL IEEECK 00177 * .. 00178 * .. Executable Statements .. 00179 * 00180 GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, 00181 $ 1100 ) ISPEC 00182 * 00183 * Invalid value for ISPEC 00184 * 00185 ILAENV = -1 00186 RETURN 00187 * 00188 100 CONTINUE 00189 * 00190 * Convert NAME to upper case if the first character is lower case. 00191 * 00192 ILAENV = 1 00193 SUBNAM = NAME 00194 IC = ICHAR( SUBNAM( 1:1 ) ) 00195 IZ = ICHAR( 'Z' ) 00196 IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN 00197 * 00198 * ASCII character set 00199 * 00200 IF( IC.GE.97 .AND. IC.LE.122 ) THEN 00201 SUBNAM( 1:1 ) = CHAR( IC-32 ) 00202 DO 10 I = 2, 6 00203 IC = ICHAR( SUBNAM( I:I ) ) 00204 IF( IC.GE.97 .AND. IC.LE.122 ) 00205 $ SUBNAM( I:I ) = CHAR( IC-32 ) 00206 10 CONTINUE 00207 END IF 00208 * 00209 ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN 00210 * 00211 * EBCDIC character set 00212 * 00213 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 00214 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 00215 $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN 00216 SUBNAM( 1:1 ) = CHAR( IC+64 ) 00217 DO 20 I = 2, 6 00218 IC = ICHAR( SUBNAM( I:I ) ) 00219 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 00220 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 00221 $ ( IC.GE.162 .AND. IC.LE.169 ) ) 00222 $ SUBNAM( I:I ) = CHAR( IC+64 ) 00223 20 CONTINUE 00224 END IF 00225 * 00226 ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN 00227 * 00228 * Prime machines: ASCII+128 00229 * 00230 IF( IC.GE.225 .AND. IC.LE.250 ) THEN 00231 SUBNAM( 1:1 ) = CHAR( IC-32 ) 00232 DO 30 I = 2, 6 00233 IC = ICHAR( SUBNAM( I:I ) ) 00234 IF( IC.GE.225 .AND. IC.LE.250 ) 00235 $ SUBNAM( I:I ) = CHAR( IC-32 ) 00236 30 CONTINUE 00237 END IF 00238 END IF 00239 * 00240 C1 = SUBNAM( 1:1 ) 00241 SNAME = C1.EQ.'S' .OR. C1.EQ.'D' 00242 CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' 00243 IF( .NOT.( CNAME .OR. SNAME ) ) 00244 $ RETURN 00245 C2 = SUBNAM( 2:3 ) 00246 C3 = SUBNAM( 4:6 ) 00247 C4 = C3( 2:3 ) 00248 * 00249 GO TO ( 110, 200, 300 ) ISPEC 00250 * 00251 110 CONTINUE 00252 * 00253 * ISPEC = 1: block size 00254 * 00255 * In these examples, separate code is provided for setting NB for 00256 * real and complex. We assume that NB will take the same value in 00257 * single or double precision. 00258 * 00259 NB = 1 00260 * 00261 IF( C2.EQ.'GE' ) THEN 00262 IF( C3.EQ.'TRF' ) THEN 00263 IF( SNAME ) THEN 00264 NB = 64 00265 ELSE 00266 NB = 64 00267 END IF 00268 ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. 00269 $ C3.EQ.'QLF' ) THEN 00270 IF( SNAME ) THEN 00271 NB = 32 00272 ELSE 00273 NB = 32 00274 END IF 00275 ELSE IF( C3.EQ.'HRD' ) THEN 00276 IF( SNAME ) THEN 00277 NB = 32 00278 ELSE 00279 NB = 32 00280 END IF 00281 ELSE IF( C3.EQ.'BRD' ) THEN 00282 IF( SNAME ) THEN 00283 NB = 32 00284 ELSE 00285 NB = 32 00286 END IF 00287 ELSE IF( C3.EQ.'TRI' ) THEN 00288 IF( SNAME ) THEN 00289 NB = 64 00290 ELSE 00291 NB = 64 00292 END IF 00293 END IF 00294 ELSE IF( C2.EQ.'PO' ) THEN 00295 IF( C3.EQ.'TRF' ) THEN 00296 IF( SNAME ) THEN 00297 NB = 64 00298 ELSE 00299 NB = 64 00300 END IF 00301 END IF 00302 ELSE IF( C2.EQ.'SY' ) THEN 00303 IF( C3.EQ.'TRF' ) THEN 00304 IF( SNAME ) THEN 00305 NB = 64 00306 ELSE 00307 NB = 64 00308 END IF 00309 ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN 00310 NB = 32 00311 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN 00312 NB = 64 00313 END IF 00314 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 00315 IF( C3.EQ.'TRF' ) THEN 00316 NB = 64 00317 ELSE IF( C3.EQ.'TRD' ) THEN 00318 NB = 32 00319 ELSE IF( C3.EQ.'GST' ) THEN 00320 NB = 64 00321 END IF 00322 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 00323 IF( C3( 1:1 ).EQ.'G' ) THEN 00324 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00325 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00326 $ C4.EQ.'BR' ) THEN 00327 NB = 32 00328 END IF 00329 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 00330 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00331 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00332 $ C4.EQ.'BR' ) THEN 00333 NB = 32 00334 END IF 00335 END IF 00336 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 00337 IF( C3( 1:1 ).EQ.'G' ) THEN 00338 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00339 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00340 $ C4.EQ.'BR' ) THEN 00341 NB = 32 00342 END IF 00343 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 00344 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00345 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00346 $ C4.EQ.'BR' ) THEN 00347 NB = 32 00348 END IF 00349 END IF 00350 ELSE IF( C2.EQ.'GB' ) THEN 00351 IF( C3.EQ.'TRF' ) THEN 00352 IF( SNAME ) THEN 00353 IF( N4.LE.64 ) THEN 00354 NB = 1 00355 ELSE 00356 NB = 32 00357 END IF 00358 ELSE 00359 IF( N4.LE.64 ) THEN 00360 NB = 1 00361 ELSE 00362 NB = 32 00363 END IF 00364 END IF 00365 END IF 00366 ELSE IF( C2.EQ.'PB' ) THEN 00367 IF( C3.EQ.'TRF' ) THEN 00368 IF( SNAME ) THEN 00369 IF( N2.LE.64 ) THEN 00370 NB = 1 00371 ELSE 00372 NB = 32 00373 END IF 00374 ELSE 00375 IF( N2.LE.64 ) THEN 00376 NB = 1 00377 ELSE 00378 NB = 32 00379 END IF 00380 END IF 00381 END IF 00382 ELSE IF( C2.EQ.'TR' ) THEN 00383 IF( C3.EQ.'TRI' ) THEN 00384 IF( SNAME ) THEN 00385 NB = 64 00386 ELSE 00387 NB = 64 00388 END IF 00389 END IF 00390 ELSE IF( C2.EQ.'LA' ) THEN 00391 IF( C3.EQ.'UUM' ) THEN 00392 IF( SNAME ) THEN 00393 NB = 64 00394 ELSE 00395 NB = 64 00396 END IF 00397 END IF 00398 ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN 00399 IF( C3.EQ.'EBZ' ) THEN 00400 NB = 1 00401 END IF 00402 END IF 00403 ILAENV = NB 00404 RETURN 00405 * 00406 200 CONTINUE 00407 * 00408 * ISPEC = 2: minimum block size 00409 * 00410 NBMIN = 2 00411 IF( C2.EQ.'GE' ) THEN 00412 IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. 00413 $ C3.EQ.'QLF' ) THEN 00414 IF( SNAME ) THEN 00415 NBMIN = 2 00416 ELSE 00417 NBMIN = 2 00418 END IF 00419 ELSE IF( C3.EQ.'HRD' ) THEN 00420 IF( SNAME ) THEN 00421 NBMIN = 2 00422 ELSE 00423 NBMIN = 2 00424 END IF 00425 ELSE IF( C3.EQ.'BRD' ) THEN 00426 IF( SNAME ) THEN 00427 NBMIN = 2 00428 ELSE 00429 NBMIN = 2 00430 END IF 00431 ELSE IF( C3.EQ.'TRI' ) THEN 00432 IF( SNAME ) THEN 00433 NBMIN = 2 00434 ELSE 00435 NBMIN = 2 00436 END IF 00437 END IF 00438 ELSE IF( C2.EQ.'SY' ) THEN 00439 IF( C3.EQ.'TRF' ) THEN 00440 IF( SNAME ) THEN 00441 NBMIN = 8 00442 ELSE 00443 NBMIN = 8 00444 END IF 00445 ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN 00446 NBMIN = 2 00447 END IF 00448 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 00449 IF( C3.EQ.'TRD' ) THEN 00450 NBMIN = 2 00451 END IF 00452 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 00453 IF( C3( 1:1 ).EQ.'G' ) THEN 00454 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00455 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00456 $ C4.EQ.'BR' ) THEN 00457 NBMIN = 2 00458 END IF 00459 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 00460 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00461 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00462 $ C4.EQ.'BR' ) THEN 00463 NBMIN = 2 00464 END IF 00465 END IF 00466 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 00467 IF( C3( 1:1 ).EQ.'G' ) THEN 00468 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00469 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00470 $ C4.EQ.'BR' ) THEN 00471 NBMIN = 2 00472 END IF 00473 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 00474 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00475 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00476 $ C4.EQ.'BR' ) THEN 00477 NBMIN = 2 00478 END IF 00479 END IF 00480 END IF 00481 ILAENV = NBMIN 00482 RETURN 00483 * 00484 300 CONTINUE 00485 * 00486 * ISPEC = 3: crossover point 00487 * 00488 NX = 0 00489 IF( C2.EQ.'GE' ) THEN 00490 IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. 00491 $ C3.EQ.'QLF' ) THEN 00492 IF( SNAME ) THEN 00493 NX = 128 00494 ELSE 00495 NX = 128 00496 END IF 00497 ELSE IF( C3.EQ.'HRD' ) THEN 00498 IF( SNAME ) THEN 00499 NX = 128 00500 ELSE 00501 NX = 128 00502 END IF 00503 ELSE IF( C3.EQ.'BRD' ) THEN 00504 IF( SNAME ) THEN 00505 NX = 128 00506 ELSE 00507 NX = 128 00508 END IF 00509 END IF 00510 ELSE IF( C2.EQ.'SY' ) THEN 00511 IF( SNAME .AND. C3.EQ.'TRD' ) THEN 00512 NX = 32 00513 END IF 00514 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 00515 IF( C3.EQ.'TRD' ) THEN 00516 NX = 32 00517 END IF 00518 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 00519 IF( C3( 1:1 ).EQ.'G' ) THEN 00520 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00521 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00522 $ C4.EQ.'BR' ) THEN 00523 NX = 128 00524 END IF 00525 END IF 00526 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 00527 IF( C3( 1:1 ).EQ.'G' ) THEN 00528 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 00529 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 00530 $ C4.EQ.'BR' ) THEN 00531 NX = 128 00532 END IF 00533 END IF 00534 END IF 00535 ILAENV = NX 00536 RETURN 00537 * 00538 400 CONTINUE 00539 * 00540 * ISPEC = 4: number of shifts (used by xHSEQR) 00541 * 00542 ILAENV = 6 00543 RETURN 00544 * 00545 500 CONTINUE 00546 * 00547 * ISPEC = 5: minimum column dimension (not used) 00548 * 00549 ILAENV = 2 00550 RETURN 00551 * 00552 600 CONTINUE 00553 * 00554 * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) 00555 * 00556 ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) 00557 RETURN 00558 * 00559 700 CONTINUE 00560 * 00561 * ISPEC = 7: number of processors (not used) 00562 * 00563 ILAENV = 1 00564 RETURN 00565 * 00566 800 CONTINUE 00567 * 00568 * ISPEC = 8: crossover point for multishift (used by xHSEQR) 00569 * 00570 ILAENV = 50 00571 RETURN 00572 * 00573 900 CONTINUE 00574 * 00575 * ISPEC = 9: maximum size of the subproblems at the bottom of the 00576 * computation tree in the divide-and-conquer algorithm 00577 * (used by xGELSD and xGESDD) 00578 * 00579 ILAENV = 25 00580 RETURN 00581 * 00582 1000 CONTINUE 00583 * 00584 * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap 00585 * 00586 ILAENV = 1 00587 IF (ILAENV .EQ. 1) THEN 00588 ILAENV = IEEECK( 0, 0.0, 1.0 ) 00589 ENDIF 00590 RETURN 00591 * 00592 1100 CONTINUE 00593 * 00594 * ISPEC = 11: infinity arithmetic can be trusted not to trap 00595 * 00596 ILAENV = 1 00597 IF (ILAENV .EQ. 1) THEN 00598 ILAENV = IEEECK( 1, 0.0, 1.0 ) 00599 ENDIF 00600 RETURN 00601 * 00602 * End of ILAENV 00603 * 00604 END 00605 INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) 00606 * 00607 * -- LAPACK auxiliary routine (version 3.2) -- 00608 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00609 * November 2006 00610 * 00611 * .. Scalar Arguments .. 00612 INTEGER ISPEC 00613 REAL ZERO, ONE 00614 * .. 00615 * 00616 * Purpose 00617 * ======= 00618 * 00619 * IEEECK is called from the ILAENV to verify that Inifinity and 00620 * possibly NaN arithmetic is safe (i.e. will not trap). 00621 * 00622 * Arguments 00623 * ========= 00624 * 00625 * ISPEC (input) INTEGER 00626 * Specifies whether to test just for inifinity arithmetic 00627 * or whether to test for infinity and NaN arithmetic. 00628 * = 0: Verify infinity arithmetic only. 00629 * = 1: Verify infinity and NaN arithmetic. 00630 * 00631 * ZERO (input) REAL 00632 * Must contain the value 0.0 00633 * This is passed to prevent the compiler from optimizing 00634 * away this code. 00635 * 00636 * ONE (input) REAL 00637 * Must contain the value 1.0 00638 * This is passed to prevent the compiler from optimizing 00639 * away this code. 00640 * 00641 * RETURN VALUE: INTEGER 00642 * = 0: Arithmetic failed to produce the correct answers 00643 * = 1: Arithmetic produced the correct answers 00644 * 00645 * .. Local Scalars .. 00646 REAL POSINF, NEGINF, NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGZRO, 00647 $ NEWZRO 00648 * .. 00649 * .. Executable Statements .. 00650 IEEECK = 1 00651 00652 POSINF = ONE /ZERO 00653 IF ( POSINF .LE. ONE ) THEN 00654 IEEECK = 0 00655 RETURN 00656 ENDIF 00657 00658 NEGINF = -ONE / ZERO 00659 IF ( NEGINF .GE. ZERO ) THEN 00660 IEEECK = 0 00661 RETURN 00662 ENDIF 00663 00664 NEGZRO = ONE / ( NEGINF + ONE ) 00665 IF ( NEGZRO .NE. ZERO ) THEN 00666 IEEECK = 0 00667 RETURN 00668 ENDIF 00669 00670 NEGINF = ONE / NEGZRO 00671 IF ( NEGINF .GE. ZERO ) THEN 00672 IEEECK = 0 00673 RETURN 00674 ENDIF 00675 00676 NEWZRO = NEGZRO + ZERO 00677 IF ( NEWZRO .NE. ZERO ) THEN 00678 IEEECK = 0 00679 RETURN 00680 ENDIF 00681 00682 POSINF = ONE / NEWZRO 00683 IF ( POSINF .LE. ONE ) THEN 00684 IEEECK = 0 00685 RETURN 00686 ENDIF 00687 00688 NEGINF = NEGINF * POSINF 00689 IF ( NEGINF .GE. ZERO ) THEN 00690 IEEECK = 0 00691 RETURN 00692 ENDIF 00693 00694 POSINF = POSINF * POSINF 00695 IF ( POSINF .LE. ONE ) THEN 00696 IEEECK = 0 00697 RETURN 00698 ENDIF 00699 00700 00701 00702 * 00703 * Return if we were only asked to check infinity arithmetic 00704 * 00705 IF (ISPEC .EQ. 0 ) RETURN 00706 00707 NAN1 = POSINF + NEGINF 00708 00709 NAN2 = POSINF / NEGINF 00710 00711 NAN3 = POSINF / POSINF 00712 00713 NAN4 = POSINF * ZERO 00714 00715 NAN5 = NEGINF * NEGZRO 00716 00717 NAN6 = NAN5 * 0.0 00718 00719 IF ( NAN1 .EQ. NAN1 ) THEN 00720 IEEECK = 0 00721 RETURN 00722 ENDIF 00723 00724 IF ( NAN2 .EQ. NAN2 ) THEN 00725 IEEECK = 0 00726 RETURN 00727 ENDIF 00728 00729 IF ( NAN3 .EQ. NAN3 ) THEN 00730 IEEECK = 0 00731 RETURN 00732 ENDIF 00733 00734 IF ( NAN4 .EQ. NAN4 ) THEN 00735 IEEECK = 0 00736 RETURN 00737 ENDIF 00738 00739 IF ( NAN5 .EQ. NAN5 ) THEN 00740 IEEECK = 0 00741 RETURN 00742 ENDIF 00743 00744 IF ( NAN6 .EQ. NAN6 ) THEN 00745 IEEECK = 0 00746 RETURN 00747 ENDIF 00748 00749 RETURN 00750 END
1.7.3 
