00001 REAL FUNCTION SLAPY3( X, Y, Z ) 00002 * 00003 * -- LAPACK auxiliary routine (version 3.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 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 REAL X, Y, Z 00010 * .. 00011 * 00012 * Purpose 00013 * ======= 00014 * 00015 * SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause 00016 * unnecessary overflow. 00017 * 00018 * Arguments 00019 * ========= 00020 * 00021 * X (input) REAL 00022 * Y (input) REAL 00023 * Z (input) REAL 00024 * X, Y and Z specify the values x, y and z. 00025 * 00026 * ===================================================================== 00027 * 00028 * .. Parameters .. 00029 REAL ZERO 00030 PARAMETER ( ZERO = 0.0E0 ) 00031 * .. 00032 * .. Local Scalars .. 00033 REAL W, XABS, YABS, ZABS 00034 * .. 00035 * .. Intrinsic Functions .. 00036 INTRINSIC ABS, MAX, SQRT 00037 * .. 00038 * .. Executable Statements .. 00039 * 00040 XABS = ABS( X ) 00041 YABS = ABS( Y ) 00042 ZABS = ABS( Z ) 00043 W = MAX( XABS, YABS, ZABS ) 00044 IF( W.EQ.ZERO ) THEN 00045 * W can be zero for max(0,nan,0) 00046 * adding all three entries together will make sure 00047 * NaN will not disappear. 00048 SLAPY3 = XABS + YABS + ZABS 00049 ELSE 00050 SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ 00051 $ ( ZABS / W )**2 ) 00052 END IF 00053 RETURN 00054 * 00055 * End of SLAPY3 00056 * 00057 END
1.7.2