1*> \brief \b TSTIEE 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Authors: 9* ======== 10* 11*> \author Univ. of Tennessee 12*> \author Univ. of California Berkeley 13*> \author Univ. of Colorado Denver 14*> \author NAG Ltd. 15* 16*> \date November 2011 17* 18*> \ingroup auxOTHERauxiliary 19* 20* ===================================================================== 21 PROGRAM TSTIEE 22* 23* -- LAPACK test routine (version 3.4.0) -- 24* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 25* November 2006 26* 27* .. External Functions .. 28 INTEGER ILAENV 29 EXTERNAL ILAENV 30* .. 31* .. Local Scalars .. 32 INTEGER IEEEOK 33* .. 34* .. Executable Statements .. 35* 36 WRITE( 6, FMT = * ) 37 $ 'We are about to check whether infinity arithmetic' 38 WRITE( 6, FMT = * )'can be trusted. If this test hangs, set' 39 WRITE( 6, FMT = * ) 40 $ 'ILAENV = 0 for ISPEC = 10 in LAPACK/SRC/ilaenv.f' 41* 42 IEEEOK = ILAENV( 10, 'ILAENV', 'N', 1, 2, 3, 4 ) 43 WRITE( 6, FMT = * ) 44* 45 IF( IEEEOK.EQ.0 ) THEN 46 WRITE( 6, FMT = * ) 47 $ 'Infinity arithmetic did not perform per the ieee spec' 48 ELSE 49 WRITE( 6, FMT = * ) 50 $ 'Infinity arithmetic performed as per the ieee spec.' 51 WRITE( 6, FMT = * ) 52 $ 'However, this is not an exhaustive test and does not' 53 WRITE( 6, FMT = * ) 54 $ 'guarantee that infinity arithmetic meets the', 55 $ ' ieee spec.' 56 END IF 57* 58 WRITE( 6, FMT = * ) 59 WRITE( 6, FMT = * ) 60 $ 'We are about to check whether NaN arithmetic' 61 WRITE( 6, FMT = * )'can be trusted. If this test hangs, set' 62 WRITE( 6, FMT = * ) 63 $ 'ILAENV = 0 for ISPEC = 11 in LAPACK/SRC/ilaenv.f' 64 IEEEOK = ILAENV( 11, 'ILAENV', 'N', 1, 2, 3, 4 ) 65* 66 WRITE( 6, FMT = * ) 67 IF( IEEEOK.EQ.0 ) THEN 68 WRITE( 6, FMT = * ) 69 $ 'NaN arithmetic did not perform per the ieee spec' 70 ELSE 71 WRITE( 6, FMT = * )'NaN arithmetic performed as per the ieee', 72 $ ' spec.' 73 WRITE( 6, FMT = * ) 74 $ 'However, this is not an exhaustive test and does not' 75 WRITE( 6, FMT = * )'guarantee that NaN arithmetic meets the', 76 $ ' ieee spec.' 77 END IF 78 WRITE( 6, FMT = * ) 79* 80 END 81 INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, 82 $ N4 ) 83* 84* -- LAPACK auxiliary routine (version 3.4.0) -- 85* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 86* November 2006 87* 88* .. Scalar Arguments .. 89 CHARACTER*( * ) NAME, OPTS 90 INTEGER ISPEC, N1, N2, N3, N4 91* .. 92* 93* Purpose 94* ======= 95* 96* ILAENV is called from the LAPACK routines to choose problem-dependent 97* parameters for the local environment. See ISPEC for a description of 98* the parameters. 99* 100* This version provides a set of parameters which should give good, 101* but not optimal, performance on many of the currently available 102* computers. Users are encouraged to modify this subroutine to set 103* the tuning parameters for their particular machine using the option 104* and problem size information in the arguments. 105* 106* This routine will not function correctly if it is converted to all 107* lower case. Converting it to all upper case is allowed. 108* 109* Arguments: 110* ========== 111* 112* ISPEC (input) INTEGER 113* Specifies the parameter to be returned as the value of 114* ILAENV. 115* = 1: the optimal blocksize; if this value is 1, an unblocked 116* algorithm will give the best performance. 117* = 2: the minimum block size for which the block routine 118* should be used; if the usable block size is less than 119* this value, an unblocked routine should be used. 120* = 3: the crossover point (in a block routine, for N less 121* than this value, an unblocked routine should be used) 122* = 4: the number of shifts, used in the nonsymmetric 123* eigenvalue routines 124* = 5: the minimum column dimension for blocking to be used; 125* rectangular blocks must have dimension at least k by m, 126* where k is given by ILAENV(2,...) and m by ILAENV(5,...) 127* = 6: the crossover point for the SVD (when reducing an m by n 128* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds 129* this value, a QR factorization is used first to reduce 130* the matrix to a triangular form.) 131* = 7: the number of processors 132* = 8: the crossover point for the multishift QR and QZ methods 133* for nonsymmetric eigenvalue problems. 134* = 9: maximum size of the subproblems at the bottom of the 135* computation tree in the divide-and-conquer algorithm 136* (used by xGELSD and xGESDD) 137* =10: ieee NaN arithmetic can be trusted not to trap 138* =11: infinity arithmetic can be trusted not to trap 139* 140* NAME (input) CHARACTER*(*) 141* The name of the calling subroutine, in either upper case or 142* lower case. 143* 144* OPTS (input) CHARACTER*(*) 145* The character options to the subroutine NAME, concatenated 146* into a single character string. For example, UPLO = 'U', 147* TRANS = 'T', and DIAG = 'N' for a triangular routine would 148* be specified as OPTS = 'UTN'. 149* 150* N1 (input) INTEGER 151* N2 (input) INTEGER 152* N3 (input) INTEGER 153* N4 (input) INTEGER 154* Problem dimensions for the subroutine NAME; these may not all 155* be required. 156* 157* (ILAENV) (output) INTEGER 158* >= 0: the value of the parameter specified by ISPEC 159* < 0: if ILAENV = -k, the k-th argument had an illegal value. 160* 161* Further Details 162* =============== 163* 164* The following conventions have been used when calling ILAENV from the 165* LAPACK routines: 166* 1) OPTS is a concatenation of all of the character options to 167* subroutine NAME, in the same order that they appear in the 168* argument list for NAME, even if they are not used in determining 169* the value of the parameter specified by ISPEC. 170* 2) The problem dimensions N1, N2, N3, N4 are specified in the order 171* that they appear in the argument list for NAME. N1 is used 172* first, N2 second, and so on, and unused problem dimensions are 173* passed a value of -1. 174* 3) The parameter value returned by ILAENV is checked for validity in 175* the calling subroutine. For example, ILAENV is used to retrieve 176* the optimal blocksize for STRTRI as follows: 177* 178* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) 179* IF( NB.LE.1 ) NB = MAX( 1, N ) 180* 181* ===================================================================== 182* 183* .. Local Scalars .. 184 LOGICAL CNAME, SNAME 185 CHARACTER*1 C1 186 CHARACTER*2 C2, C4 187 CHARACTER*3 C3 188 CHARACTER*6 SUBNAM 189 INTEGER I, IC, IZ, NB, NBMIN, NX 190* .. 191* .. Intrinsic Functions .. 192 INTRINSIC CHAR, ICHAR, INT, MIN, REAL 193* .. 194* .. External Functions .. 195 INTEGER IEEECK 196 EXTERNAL IEEECK 197* .. 198* .. Executable Statements .. 199* 200 GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, 201 $ 1100 ) ISPEC 202* 203* Invalid value for ISPEC 204* 205 ILAENV = -1 206 RETURN 207* 208 100 CONTINUE 209* 210* Convert NAME to upper case if the first character is lower case. 211* 212 ILAENV = 1 213 SUBNAM = NAME 214 IC = ICHAR( SUBNAM( 1:1 ) ) 215 IZ = ICHAR( 'Z' ) 216 IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN 217* 218* ASCII character set 219* 220 IF( IC.GE.97 .AND. IC.LE.122 ) THEN 221 SUBNAM( 1:1 ) = CHAR( IC-32 ) 222 DO 10 I = 2, 6 223 IC = ICHAR( SUBNAM( I:I ) ) 224 IF( IC.GE.97 .AND. IC.LE.122 ) 225 $ SUBNAM( I:I ) = CHAR( IC-32 ) 226 10 CONTINUE 227 END IF 228* 229 ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN 230* 231* EBCDIC character set 232* 233 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 234 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 235 $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN 236 SUBNAM( 1:1 ) = CHAR( IC+64 ) 237 DO 20 I = 2, 6 238 IC = ICHAR( SUBNAM( I:I ) ) 239 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 240 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 241 $ ( IC.GE.162 .AND. IC.LE.169 ) ) 242 $ SUBNAM( I:I ) = CHAR( IC+64 ) 243 20 CONTINUE 244 END IF 245* 246 ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN 247* 248* Prime machines: ASCII+128 249* 250 IF( IC.GE.225 .AND. IC.LE.250 ) THEN 251 SUBNAM( 1:1 ) = CHAR( IC-32 ) 252 DO 30 I = 2, 6 253 IC = ICHAR( SUBNAM( I:I ) ) 254 IF( IC.GE.225 .AND. IC.LE.250 ) 255 $ SUBNAM( I:I ) = CHAR( IC-32 ) 256 30 CONTINUE 257 END IF 258 END IF 259* 260 C1 = SUBNAM( 1:1 ) 261 SNAME = C1.EQ.'S' .OR. C1.EQ.'D' 262 CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' 263 IF( .NOT.( CNAME .OR. SNAME ) ) 264 $ RETURN 265 C2 = SUBNAM( 2:3 ) 266 C3 = SUBNAM( 4:6 ) 267 C4 = C3( 2:3 ) 268* 269 GO TO ( 110, 200, 300 ) ISPEC 270* 271 110 CONTINUE 272* 273* ISPEC = 1: block size 274* 275* In these examples, separate code is provided for setting NB for 276* real and complex. We assume that NB will take the same value in 277* single or double precision. 278* 279 NB = 1 280* 281 IF( C2.EQ.'GE' ) THEN 282 IF( C3.EQ.'TRF' ) THEN 283 IF( SNAME ) THEN 284 NB = 64 285 ELSE 286 NB = 64 287 END IF 288 ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. 289 $ C3.EQ.'QLF' ) THEN 290 IF( SNAME ) THEN 291 NB = 32 292 ELSE 293 NB = 32 294 END IF 295 ELSE IF( C3.EQ.'HRD' ) THEN 296 IF( SNAME ) THEN 297 NB = 32 298 ELSE 299 NB = 32 300 END IF 301 ELSE IF( C3.EQ.'BRD' ) THEN 302 IF( SNAME ) THEN 303 NB = 32 304 ELSE 305 NB = 32 306 END IF 307 ELSE IF( C3.EQ.'TRI' ) THEN 308 IF( SNAME ) THEN 309 NB = 64 310 ELSE 311 NB = 64 312 END IF 313 END IF 314 ELSE IF( C2.EQ.'PO' ) THEN 315 IF( C3.EQ.'TRF' ) THEN 316 IF( SNAME ) THEN 317 NB = 64 318 ELSE 319 NB = 64 320 END IF 321 END IF 322 ELSE IF( C2.EQ.'SY' ) THEN 323 IF( C3.EQ.'TRF' ) THEN 324 IF( SNAME ) THEN 325 NB = 64 326 ELSE 327 NB = 64 328 END IF 329 ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN 330 NB = 32 331 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN 332 NB = 64 333 END IF 334 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 335 IF( C3.EQ.'TRF' ) THEN 336 NB = 64 337 ELSE IF( C3.EQ.'TRD' ) THEN 338 NB = 32 339 ELSE IF( C3.EQ.'GST' ) THEN 340 NB = 64 341 END IF 342 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 343 IF( C3( 1:1 ).EQ.'G' ) THEN 344 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 345 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 346 $ C4.EQ.'BR' ) THEN 347 NB = 32 348 END IF 349 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 350 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 351 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 352 $ C4.EQ.'BR' ) THEN 353 NB = 32 354 END IF 355 END IF 356 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 357 IF( C3( 1:1 ).EQ.'G' ) THEN 358 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 359 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 360 $ C4.EQ.'BR' ) THEN 361 NB = 32 362 END IF 363 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 364 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 365 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 366 $ C4.EQ.'BR' ) THEN 367 NB = 32 368 END IF 369 END IF 370 ELSE IF( C2.EQ.'GB' ) THEN 371 IF( C3.EQ.'TRF' ) THEN 372 IF( SNAME ) THEN 373 IF( N4.LE.64 ) THEN 374 NB = 1 375 ELSE 376 NB = 32 377 END IF 378 ELSE 379 IF( N4.LE.64 ) THEN 380 NB = 1 381 ELSE 382 NB = 32 383 END IF 384 END IF 385 END IF 386 ELSE IF( C2.EQ.'PB' ) THEN 387 IF( C3.EQ.'TRF' ) THEN 388 IF( SNAME ) THEN 389 IF( N2.LE.64 ) THEN 390 NB = 1 391 ELSE 392 NB = 32 393 END IF 394 ELSE 395 IF( N2.LE.64 ) THEN 396 NB = 1 397 ELSE 398 NB = 32 399 END IF 400 END IF 401 END IF 402 ELSE IF( C2.EQ.'TR' ) THEN 403 IF( C3.EQ.'TRI' ) THEN 404 IF( SNAME ) THEN 405 NB = 64 406 ELSE 407 NB = 64 408 END IF 409 END IF 410 ELSE IF( C2.EQ.'LA' ) THEN 411 IF( C3.EQ.'UUM' ) THEN 412 IF( SNAME ) THEN 413 NB = 64 414 ELSE 415 NB = 64 416 END IF 417 END IF 418 ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN 419 IF( C3.EQ.'EBZ' ) THEN 420 NB = 1 421 END IF 422 END IF 423 ILAENV = NB 424 RETURN 425* 426 200 CONTINUE 427* 428* ISPEC = 2: minimum block size 429* 430 NBMIN = 2 431 IF( C2.EQ.'GE' ) THEN 432 IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. 433 $ C3.EQ.'QLF' ) THEN 434 IF( SNAME ) THEN 435 NBMIN = 2 436 ELSE 437 NBMIN = 2 438 END IF 439 ELSE IF( C3.EQ.'HRD' ) THEN 440 IF( SNAME ) THEN 441 NBMIN = 2 442 ELSE 443 NBMIN = 2 444 END IF 445 ELSE IF( C3.EQ.'BRD' ) THEN 446 IF( SNAME ) THEN 447 NBMIN = 2 448 ELSE 449 NBMIN = 2 450 END IF 451 ELSE IF( C3.EQ.'TRI' ) THEN 452 IF( SNAME ) THEN 453 NBMIN = 2 454 ELSE 455 NBMIN = 2 456 END IF 457 END IF 458 ELSE IF( C2.EQ.'SY' ) THEN 459 IF( C3.EQ.'TRF' ) THEN 460 IF( SNAME ) THEN 461 NBMIN = 8 462 ELSE 463 NBMIN = 8 464 END IF 465 ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN 466 NBMIN = 2 467 END IF 468 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 469 IF( C3.EQ.'TRD' ) THEN 470 NBMIN = 2 471 END IF 472 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 473 IF( C3( 1:1 ).EQ.'G' ) THEN 474 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 475 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 476 $ C4.EQ.'BR' ) THEN 477 NBMIN = 2 478 END IF 479 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 480 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 481 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 482 $ C4.EQ.'BR' ) THEN 483 NBMIN = 2 484 END IF 485 END IF 486 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 487 IF( C3( 1:1 ).EQ.'G' ) THEN 488 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 489 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 490 $ C4.EQ.'BR' ) THEN 491 NBMIN = 2 492 END IF 493 ELSE IF( C3( 1:1 ).EQ.'M' ) THEN 494 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 495 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 496 $ C4.EQ.'BR' ) THEN 497 NBMIN = 2 498 END IF 499 END IF 500 END IF 501 ILAENV = NBMIN 502 RETURN 503* 504 300 CONTINUE 505* 506* ISPEC = 3: crossover point 507* 508 NX = 0 509 IF( C2.EQ.'GE' ) THEN 510 IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. 511 $ C3.EQ.'QLF' ) THEN 512 IF( SNAME ) THEN 513 NX = 128 514 ELSE 515 NX = 128 516 END IF 517 ELSE IF( C3.EQ.'HRD' ) THEN 518 IF( SNAME ) THEN 519 NX = 128 520 ELSE 521 NX = 128 522 END IF 523 ELSE IF( C3.EQ.'BRD' ) THEN 524 IF( SNAME ) THEN 525 NX = 128 526 ELSE 527 NX = 128 528 END IF 529 END IF 530 ELSE IF( C2.EQ.'SY' ) THEN 531 IF( SNAME .AND. C3.EQ.'TRD' ) THEN 532 NX = 32 533 END IF 534 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 535 IF( C3.EQ.'TRD' ) THEN 536 NX = 32 537 END IF 538 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 539 IF( C3( 1:1 ).EQ.'G' ) THEN 540 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 541 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 542 $ C4.EQ.'BR' ) THEN 543 NX = 128 544 END IF 545 END IF 546 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 547 IF( C3( 1:1 ).EQ.'G' ) THEN 548 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. 549 $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. 550 $ C4.EQ.'BR' ) THEN 551 NX = 128 552 END IF 553 END IF 554 END IF 555 ILAENV = NX 556 RETURN 557* 558 400 CONTINUE 559* 560* ISPEC = 4: number of shifts (used by xHSEQR) 561* 562 ILAENV = 6 563 RETURN 564* 565 500 CONTINUE 566* 567* ISPEC = 5: minimum column dimension (not used) 568* 569 ILAENV = 2 570 RETURN 571* 572 600 CONTINUE 573* 574* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) 575* 576 ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) 577 RETURN 578* 579 700 CONTINUE 580* 581* ISPEC = 7: number of processors (not used) 582* 583 ILAENV = 1 584 RETURN 585* 586 800 CONTINUE 587* 588* ISPEC = 8: crossover point for multishift (used by xHSEQR) 589* 590 ILAENV = 50 591 RETURN 592* 593 900 CONTINUE 594* 595* ISPEC = 9: maximum size of the subproblems at the bottom of the 596* computation tree in the divide-and-conquer algorithm 597* (used by xGELSD and xGESDD) 598* 599 ILAENV = 25 600 RETURN 601* 602 1000 CONTINUE 603* 604* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap 605* 606 ILAENV = 1 607 IF (ILAENV .EQ. 1) THEN 608 ILAENV = IEEECK( 0, 0.0, 1.0 ) 609 ENDIF 610 RETURN 611* 612 1100 CONTINUE 613* 614* ISPEC = 11: infinity arithmetic can be trusted not to trap 615* 616 ILAENV = 1 617 IF (ILAENV .EQ. 1) THEN 618 ILAENV = IEEECK( 1, 0.0, 1.0 ) 619 ENDIF 620 RETURN 621* 622* End of ILAENV 623* 624 END 625 INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) 626* 627* -- LAPACK auxiliary routine (version 3.4.0) -- 628* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 629* November 2006 630* 631* .. Scalar Arguments .. 632 INTEGER ISPEC 633 REAL ZERO, ONE 634* .. 635* 636* Purpose 637* ======= 638* 639* IEEECK is called from the ILAENV to verify that Inifinity and 640* possibly NaN arithmetic is safe (i.e. will not trap). 641* 642* Arguments: 643* ========== 644* 645* ISPEC (input) INTEGER 646* Specifies whether to test just for inifinity arithmetic 647* or whether to test for infinity and NaN arithmetic. 648* = 0: Verify infinity arithmetic only. 649* = 1: Verify infinity and NaN arithmetic. 650* 651* ZERO (input) REAL 652* Must contain the value 0.0 653* This is passed to prevent the compiler from optimizing 654* away this code. 655* 656* ONE (input) REAL 657* Must contain the value 1.0 658* This is passed to prevent the compiler from optimizing 659* away this code. 660* 661* RETURN VALUE: INTEGER 662* = 0: Arithmetic failed to produce the correct answers 663* = 1: Arithmetic produced the correct answers 664* 665* .. Local Scalars .. 666 REAL POSINF, NEGINF, NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGZRO, 667 $ NEWZRO 668* .. 669* .. Executable Statements .. 670 IEEECK = 1 671 672 POSINF = ONE /ZERO 673 IF ( POSINF .LE. ONE ) THEN 674 IEEECK = 0 675 RETURN 676 ENDIF 677 678 NEGINF = -ONE / ZERO 679 IF ( NEGINF .GE. ZERO ) THEN 680 IEEECK = 0 681 RETURN 682 ENDIF 683 684 NEGZRO = ONE / ( NEGINF + ONE ) 685 IF ( NEGZRO .NE. ZERO ) THEN 686 IEEECK = 0 687 RETURN 688 ENDIF 689 690 NEGINF = ONE / NEGZRO 691 IF ( NEGINF .GE. ZERO ) THEN 692 IEEECK = 0 693 RETURN 694 ENDIF 695 696 NEWZRO = NEGZRO + ZERO 697 IF ( NEWZRO .NE. ZERO ) THEN 698 IEEECK = 0 699 RETURN 700 ENDIF 701 702 POSINF = ONE / NEWZRO 703 IF ( POSINF .LE. ONE ) THEN 704 IEEECK = 0 705 RETURN 706 ENDIF 707 708 NEGINF = NEGINF * POSINF 709 IF ( NEGINF .GE. ZERO ) THEN 710 IEEECK = 0 711 RETURN 712 ENDIF 713 714 POSINF = POSINF * POSINF 715 IF ( POSINF .LE. ONE ) THEN 716 IEEECK = 0 717 RETURN 718 ENDIF 719 720 721 722* 723* Return if we were only asked to check infinity arithmetic 724* 725 IF (ISPEC .EQ. 0 ) RETURN 726 727 NAN1 = POSINF + NEGINF 728 729 NAN2 = POSINF / NEGINF 730 731 NAN3 = POSINF / POSINF 732 733 NAN4 = POSINF * ZERO 734 735 NAN5 = NEGINF * NEGZRO 736 737 NAN6 = NAN5 * 0.0 738 739 IF ( NAN1 .EQ. NAN1 ) THEN 740 IEEECK = 0 741 RETURN 742 ENDIF 743 744 IF ( NAN2 .EQ. NAN2 ) THEN 745 IEEECK = 0 746 RETURN 747 ENDIF 748 749 IF ( NAN3 .EQ. NAN3 ) THEN 750 IEEECK = 0 751 RETURN 752 ENDIF 753 754 IF ( NAN4 .EQ. NAN4 ) THEN 755 IEEECK = 0 756 RETURN 757 ENDIF 758 759 IF ( NAN5 .EQ. NAN5 ) THEN 760 IEEECK = 0 761 RETURN 762 ENDIF 763 764 IF ( NAN6 .EQ. NAN6 ) THEN 765 IEEECK = 0 766 RETURN 767 ENDIF 768 769 RETURN 770 END 771