LAPACK: SRC/ieeeck.f Source File

Go to the documentation of this file.
00001       INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
00002 *
00003 *  -- LAPACK auxiliary routine (version 3.2.2) --
00004 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00005 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00006 *     June 2010
00007 *
00008 *     .. Scalar Arguments ..
00009       INTEGER            ISPEC
00010       REAL               ONE, ZERO
00011 *     ..
00012 *
00013 *  Purpose
00014 *  =======
00015 *
00016 *  IEEECK is called from the ILAENV to verify that Infinity and
00017 *  possibly NaN arithmetic is safe (i.e. will not trap).
00018 *
00019 *  Arguments
00020 *  =========
00021 *
00022 *  ISPEC   (input) INTEGER
00023 *          Specifies whether to test just for inifinity arithmetic
00024 *          or whether to test for infinity and NaN arithmetic.
00025 *          = 0: Verify infinity arithmetic only.
00026 *          = 1: Verify infinity and NaN arithmetic.
00027 *
00028 *  ZERO    (input) REAL
00029 *          Must contain the value 0.0
00030 *          This is passed to prevent the compiler from optimizing
00031 *          away this code.
00032 *
00033 *  ONE     (input) REAL
00034 *          Must contain the value 1.0
00035 *          This is passed to prevent the compiler from optimizing
00036 *          away this code.
00037 *
00038 *  RETURN VALUE:  INTEGER
00039 *          = 0:  Arithmetic failed to produce the correct answers
00040 *          = 1:  Arithmetic produced the correct answers
00041 *
00042 *     .. Local Scalars ..
00043       REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
00044      $                   NEGZRO, NEWZRO, POSINF
00045 *     ..
00046 *     .. Executable Statements ..
00047       IEEECK = 1
00048 *
00049       POSINF = ONE / ZERO
00050       IF( POSINF.LE.ONE ) THEN
00051          IEEECK = 0
00052          RETURN
00053       END IF
00054 *
00055       NEGINF = -ONE / ZERO
00056       IF( NEGINF.GE.ZERO ) THEN
00057          IEEECK = 0
00058          RETURN
00059       END IF
00060 *
00061       NEGZRO = ONE / ( NEGINF+ONE )
00062       IF( NEGZRO.NE.ZERO ) THEN
00063          IEEECK = 0
00064          RETURN
00065       END IF
00066 *
00067       NEGINF = ONE / NEGZRO
00068       IF( NEGINF.GE.ZERO ) THEN
00069          IEEECK = 0
00070          RETURN
00071       END IF
00072 *
00073       NEWZRO = NEGZRO + ZERO
00074       IF( NEWZRO.NE.ZERO ) THEN
00075          IEEECK = 0
00076          RETURN
00077       END IF
00078 *
00079       POSINF = ONE / NEWZRO
00080       IF( POSINF.LE.ONE ) THEN
00081          IEEECK = 0
00082          RETURN
00083       END IF
00084 *
00085       NEGINF = NEGINF*POSINF
00086       IF( NEGINF.GE.ZERO ) THEN
00087          IEEECK = 0
00088          RETURN
00089       END IF
00090 *
00091       POSINF = POSINF*POSINF
00092       IF( POSINF.LE.ONE ) THEN
00093          IEEECK = 0
00094          RETURN
00095       END IF
00096 *
00097 *
00098 *
00099 *
00100 *     Return if we were only asked to check infinity arithmetic
00101 *
00102       IF( ISPEC.EQ.0 )
00103      $   RETURN
00104 *
00105       NAN1 = POSINF + NEGINF
00106 *
00107       NAN2 = POSINF / NEGINF
00108 *
00109       NAN3 = POSINF / POSINF
00110 *
00111       NAN4 = POSINF*ZERO
00112 *
00113       NAN5 = NEGINF*NEGZRO
00114 *
00115       NAN6 = NAN5*ZERO
00116 *
00117       IF( NAN1.EQ.NAN1 ) THEN
00118          IEEECK = 0
00119          RETURN
00120       END IF
00121 *
00122       IF( NAN2.EQ.NAN2 ) THEN
00123          IEEECK = 0
00124          RETURN
00125       END IF
00126 *
00127       IF( NAN3.EQ.NAN3 ) THEN
00128          IEEECK = 0
00129          RETURN
00130       END IF
00131 *
00132       IF( NAN4.EQ.NAN4 ) THEN
00133          IEEECK = 0
00134          RETURN
00135       END IF
00136 *
00137       IF( NAN5.EQ.NAN5 ) THEN
00138          IEEECK = 0
00139          RETURN
00140       END IF
00141 *
00142       IF( NAN6.EQ.NAN6 ) THEN
00143          IEEECK = 0
00144          RETURN
00145       END IF
00146 *
00147       RETURN
00148       END