Chris@202: /* ieeeck.f -- translated by f2c (version 20061008).
Chris@202:    You must link the resulting object file with libf2c:
Chris@202: 	on Microsoft Windows system, link with libf2c.lib;
Chris@202: 	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
Chris@202: 	or, if you install libf2c.a in a standard place, with -lf2c -lm
Chris@202: 	-- in that order, at the end of the command line, as in
Chris@202: 		cc *.o -lf2c -lm
Chris@202: 	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
Chris@202: 
Chris@202: 		http://www.netlib.org/f2c/libf2c.zip
Chris@202: */
Chris@202: 
Chris@202: #include "f2c.h"
Chris@202: #include "blaswrap.h"
Chris@202: 
Chris@202: integer ieeeck_(integer *ispec, real *zero, real *one)
Chris@202: {
Chris@202:     /* System generated locals */
Chris@202:     integer ret_val;
Chris@202: 
Chris@202:     /* Local variables */
Chris@202:     real nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro;
Chris@202: 
Chris@202: 
Chris@202: /*  -- LAPACK auxiliary routine (version 3.2) -- */
Chris@202: /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
Chris@202: /*     November 2006 */
Chris@202: 
Chris@202: /*     .. Scalar Arguments .. */
Chris@202: /*     .. */
Chris@202: 
Chris@202: /*  Purpose */
Chris@202: /*  ======= */
Chris@202: 
Chris@202: /*  IEEECK is called from the ILAENV to verify that Infinity and */
Chris@202: /*  possibly NaN arithmetic is safe (i.e. will not trap). */
Chris@202: 
Chris@202: /*  Arguments */
Chris@202: /*  ========= */
Chris@202: 
Chris@202: /*  ISPEC   (input) INTEGER */
Chris@202: /*          Specifies whether to test just for inifinity arithmetic */
Chris@202: /*          or whether to test for infinity and NaN arithmetic. */
Chris@202: /*          = 0: Verify infinity arithmetic only. */
Chris@202: /*          = 1: Verify infinity and NaN arithmetic. */
Chris@202: 
Chris@202: /*  ZERO    (input) REAL */
Chris@202: /*          Must contain the value 0.0 */
Chris@202: /*          This is passed to prevent the compiler from optimizing */
Chris@202: /*          away this code. */
Chris@202: 
Chris@202: /*  ONE     (input) REAL */
Chris@202: /*          Must contain the value 1.0 */
Chris@202: /*          This is passed to prevent the compiler from optimizing */
Chris@202: /*          away this code. */
Chris@202: 
Chris@202: /*  RETURN VALUE:  INTEGER */
Chris@202: /*          = 0:  Arithmetic failed to produce the correct answers */
Chris@202: /*          = 1:  Arithmetic produced the correct answers */
Chris@202: 
Chris@202: /*     .. Local Scalars .. */
Chris@202: /*     .. */
Chris@202: /*     .. Executable Statements .. */
Chris@202:     ret_val = 1;
Chris@202: 
Chris@202:     posinf = *one / *zero;
Chris@202:     if (posinf <= *one) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     neginf = -(*one) / *zero;
Chris@202:     if (neginf >= *zero) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     negzro = *one / (neginf + *one);
Chris@202:     if (negzro != *zero) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     neginf = *one / negzro;
Chris@202:     if (neginf >= *zero) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     newzro = negzro + *zero;
Chris@202:     if (newzro != *zero) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     posinf = *one / newzro;
Chris@202:     if (posinf <= *one) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     neginf *= posinf;
Chris@202:     if (neginf >= *zero) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     posinf *= posinf;
Chris@202:     if (posinf <= *one) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202: 
Chris@202: 
Chris@202: 
Chris@202: /*     Return if we were only asked to check infinity arithmetic */
Chris@202: 
Chris@202:     if (*ispec == 0) {
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     nan1 = posinf + neginf;
Chris@202: 
Chris@202:     nan2 = posinf / neginf;
Chris@202: 
Chris@202:     nan3 = posinf / posinf;
Chris@202: 
Chris@202:     nan4 = posinf * *zero;
Chris@202: 
Chris@202:     nan5 = neginf * negzro;
Chris@202: 
Chris@202:     nan6 = nan5 * 0.f;
Chris@202: 
Chris@202:     if (nan1 == nan1) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     if (nan2 == nan2) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     if (nan3 == nan3) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     if (nan4 == nan4) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     if (nan5 == nan5) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     if (nan6 == nan6) {
Chris@202: 	ret_val = 0;
Chris@202: 	return ret_val;
Chris@202:     }
Chris@202: 
Chris@202:     return ret_val;
Chris@202: } /* ieeeck_ */