LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
tstiee.f
Go to the documentation of this file.
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