The R Project SVN R

Rev

Rev 14286 | Rev 36302 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 14286 Rev 22546
Line 1... Line -...
1 
      DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
 - 
 
2 
*
 - 
 
3 
*  -- LAPACK auxiliary routine (version 3.0) --
 - 
 
4 
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
 - 
 
5 
*     Courant Institute, Argonne National Lab, and Rice University
 - 
 
6 
*     October 31, 1992
 - 
 
7 
*
 - 
 
8 
*     .. Scalar Arguments ..
 - 
 
9 
      DOUBLE PRECISION   X, Y, Z
 - 
 
10 
*     ..
 - 
 
11 
*
 - 
 
12 
*  Purpose
 - 
 
13 
*  =======
 - 
 
14 
*
 - 
 
15 
*  DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
 - 
 
16 
*  unnecessary overflow.
 - 
 
17 
*
 - 
 
18 
*  Arguments
 - 
 
19 
*  =========
 - 
 
20 
*
 - 
 
21 
*  X       (input) DOUBLE PRECISION
 - 
 
22 
*  Y       (input) DOUBLE PRECISION
 - 
 
23 
*  Z       (input) DOUBLE PRECISION
 - 
 
24 
*          X, Y and Z specify the values x, y and z.
 - 
 
25 
*
 - 
 
26 
*  =====================================================================
 - 
 
27 
*
 - 
 
28 
*     .. Parameters ..
 - 
 
29 
      DOUBLE PRECISION   ZERO
 - 
 
30 
      PARAMETER          ( ZERO = 0.0D0 )
 - 
 
31 
*     ..
 - 
 
32 
*     .. Local Scalars ..
 - 
 
33 
      DOUBLE PRECISION   W, XABS, YABS, ZABS
 - 
 
34 
*     ..
 - 
 
35 
*     .. Intrinsic Functions ..
 - 
 
36 
      INTRINSIC          ABS, MAX, SQRT
 - 
 
37 
*     ..
 - 
 
38 
*     .. Executable Statements ..
 - 
 
39 
*
 - 
 
40 
      XABS = ABS( X )
 - 
 
41 
      YABS = ABS( Y )
 - 
 
42 
      ZABS = ABS( Z )
 - 
 
43 
      W = MAX( XABS, YABS, ZABS )
 - 
 
44 
      IF( W.EQ.ZERO ) THEN
 - 
 
45 
         DLAPY3 = ZERO
 - 
 
46 
      ELSE
 - 
 
47 
         DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
 - 
 
48 
     $            ( ZABS / W )**2 )
 - 
 
49 
      END IF
 - 
 
50 
      RETURN
 - 
 
51 
*
 - 
 
52 
*     End of DLAPY3
 - 
 
53 
*
 - 
 
54 
      END
 - 
 
55 
      SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
 1 
      SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
56 
     $                   LDU, C, LDC, RWORK, INFO )
 2 
     $                   LDU, C, LDC, RWORK, INFO )
57 
*
 3 
*
58 
*  -- LAPACK routine (version 3.0) --
 4 
*  -- LAPACK routine (version 3.0) --
59 
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
 5 
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,