diff options
| author | jason <jason@8a072113-8704-0410-8d35-dd094bca7971> | 2008-10-28 01:38:50 +0000 |
|---|---|---|
| committer | jason <jason@8a072113-8704-0410-8d35-dd094bca7971> | 2008-10-28 01:38:50 +0000 |
| commit | baba851215b44ac3b60b9248eb02bcce7eb76247 (patch) | |
| tree | 8c0f5c006875532a30d4409f5e94b0f310ff00a7 /SRC/slapy3.f | |
Move LAPACK trunk into position.
Diffstat (limited to 'SRC/slapy3.f')
| -rw-r--r-- | SRC/slapy3.f | 56 |
1 files changed, 56 insertions, 0 deletions
diff --git a/SRC/slapy3.f b/SRC/slapy3.f new file mode 100644 index 00000000..f5db3853 --- /dev/null +++ b/SRC/slapy3.f @@ -0,0 +1,56 @@ + REAL FUNCTION SLAPY3( X, Y, Z ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + REAL X, Y, Z +* .. +* +* Purpose +* ======= +* +* SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause +* unnecessary overflow. +* +* Arguments +* ========= +* +* X (input) REAL +* Y (input) REAL +* Z (input) REAL +* X, Y and Z specify the values x, y and z. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E0 ) +* .. +* .. Local Scalars .. + REAL W, XABS, YABS, ZABS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + ZABS = ABS( Z ) + W = MAX( XABS, YABS, ZABS ) + IF( W.EQ.ZERO ) THEN +* W can be zero for max(0,nan,0) +* adding all three entries together will make sure +* NaN will not disappear. + SLAPY3 = XABS + YABS + ZABS + ELSE + SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ + $ ( ZABS / W )**2 ) + END IF + RETURN +* +* End of SLAPY3 +* + END |