dlasv2.f

Go to the documentation of this file.

      SUBROUTINE dlasv2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
*     ..
*
*  Purpose
*  =======
*
*  DLASV2 computes the singular value decomposition of a 2-by-2
*  triangular matrix
*     [  F   G  ]
*     [  0   H  ].
*  On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
*  smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
*  right singular vectors for abs(SSMAX), giving the decomposition
*
*     [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]
*     [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].
*
*  Arguments
*  =========
*
*  F       (input) DOUBLE PRECISION
*          The (1,1) element of the 2-by-2 matrix.
*
*  G       (input) DOUBLE PRECISION
*          The (1,2) element of the 2-by-2 matrix.
*
*  H       (input) DOUBLE PRECISION
*          The (2,2) element of the 2-by-2 matrix.
*
*  SSMIN   (output) DOUBLE PRECISION
*          abs(SSMIN) is the smaller singular value.
*
*  SSMAX   (output) DOUBLE PRECISION
*          abs(SSMAX) is the larger singular value.
*
*  SNL     (output) DOUBLE PRECISION
*  CSL     (output) DOUBLE PRECISION
*          The vector (CSL, SNL) is a unit left singular vector for the
*          singular value abs(SSMAX).
*
*  SNR     (output) DOUBLE PRECISION
*  CSR     (output) DOUBLE PRECISION
*          The vector (CSR, SNR) is a unit right singular vector for the
*          singular value abs(SSMAX).
*
*  Further Details
*  ===============
*
*  Any input parameter may be aliased with any output parameter.
*
*  Barring over/underflow and assuming a guard digit in subtraction, all
*  output quantities are correct to within a few units in the last
*  place (ulps).
*
*  In IEEE arithmetic, the code works correctly if one matrix element is
*  infinite.
*
*  Overflow will not occur unless the largest singular value itself
*  overflows or is within a few ulps of overflow. (On machines with
*  partial overflow, like the Cray, overflow may occur if the largest
*  singular value is within a factor of 2 of overflow.)
*
*  Underflow is harmless if underflow is gradual. Otherwise, results
*  may correspond to a matrix modified by perturbations of size near
*  the underflow threshold.
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
      DOUBLE PRECISION   HALF
      parameter( half = 0.5d0 )
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
      DOUBLE PRECISION   TWO
      parameter( two = 2.0d0 )
      DOUBLE PRECISION   FOUR
      parameter( four = 4.0d0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            GASMAL, SWAP
      INTEGER            PMAX
      DOUBLE PRECISION   A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
     $                   MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign, sqrt
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. Executable Statements ..
*
      ft = f
      fa = abs( ft )
      ht = h
      ha = abs( h )
*
*     PMAX points to the maximum absolute element of matrix
*       PMAX = 1 if F largest in absolute values
*       PMAX = 2 if G largest in absolute values
*       PMAX = 3 if H largest in absolute values
*
      pmax = 1
      swap = ( ha.GT.fa )
      IF( swap ) THEN
         pmax = 3
         temp = ft
         ft = ht
         ht = temp
         temp = fa
         fa = ha
         ha = temp
*
*        Now FA .ge. HA
*
      END IF
      gt = g
      ga = abs( gt )
      IF( ga.EQ.zero ) THEN
*
*        Diagonal matrix
*
         ssmin = ha
         ssmax = fa
         clt = one
         crt = one
         slt = zero
         srt = zero
      ELSE
         gasmal = .true.
         IF( ga.GT.fa ) THEN
            pmax = 2
            IF( ( fa / ga ).LT.dlamch( 'EPS' ) ) THEN
*
*              Case of very large GA
*
               gasmal = .false.
               ssmax = ga
               IF( ha.GT.one ) THEN
                  ssmin = fa / ( ga / ha )
               ELSE
                  ssmin = ( fa / ga )*ha
               END IF
               clt = one
               slt = ht / gt
               srt = one
               crt = ft / gt
            END IF
         END IF
         IF( gasmal ) THEN
*
*           Normal case
*
            d = fa - ha
            IF( d.EQ.fa ) THEN
*
*              Copes with infinite F or H
*
               l = one
            ELSE
               l = d / fa
            END IF
*
*           Note that 0 .le. L .le. 1
*
            m = gt / ft
*
*           Note that abs(M) .le. 1/macheps
*
            t = two - l
*
*           Note that T .ge. 1
*
            mm = m*m
            tt = t*t
            s = sqrt( tt+mm )
*
*           Note that 1 .le. S .le. 1 + 1/macheps
*
            IF( l.EQ.zero ) THEN
               r = abs( m )
            ELSE
               r = sqrt( l*l+mm )
            END IF
*
*           Note that 0 .le. R .le. 1 + 1/macheps
*
            a = half*( s+r )
*
*           Note that 1 .le. A .le. 1 + abs(M)
*
            ssmin = ha / a
            ssmax = fa*a
            IF( mm.EQ.zero ) THEN
*
*              Note that M is very tiny
*
               IF( l.EQ.zero ) THEN
                  t = sign( two, ft )*sign( one, gt )
               ELSE
                  t = gt / sign( d, ft ) + m / t
               END IF
            ELSE
               t = ( m / ( s+t )+m / ( r+l ) )*( one+a )
            END IF
            l = sqrt( t*t+four )
            crt = two / l
            srt = t / l
            clt = ( crt+srt*m ) / a
            slt = ( ht / ft )*srt / a
         END IF
      END IF
      IF( swap ) THEN
         csl = srt
         snl = crt
         csr = slt
         snr = clt
      ELSE
         csl = clt
         snl = slt
         csr = crt
         snr = srt
      END IF
*
*     Correct signs of SSMAX and SSMIN
*
      IF( pmax.EQ.1 )
     $   tsign = sign( one, csr )*sign( one, csl )*sign( one, f )
      IF( pmax.EQ.2 )
     $   tsign = sign( one, snr )*sign( one, csl )*sign( one, g )
      IF( pmax.EQ.3 )
     $   tsign = sign( one, snr )*sign( one, snl )*sign( one, h )
      ssmax = sign( ssmax, tsign )
      ssmin = sign( ssmin, tsign*sign( one, f )*sign( one, h ) )
      RETURN
*
*     End of DLASV2
*
      END