clanv2.f

Go to the documentation of this file.

      SUBROUTINE clanv2( A, B, C, D, RT1, RT2, CS, SN )
*
*  -- ScaLAPACK routine (version 1.7) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     May 28, 1999
*
*     .. Scalar Arguments ..
      REAL               CS
      COMPLEX            A, B, C, D, RT1, RT2, SN
*     ..
*
*  Purpose
*  =======
*
*  CLANV2 computes the Schur factorization of a complex 2-by-2
*  nonhermitian matrix in standard form:
*
*       [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
*       [ C  D ]   [ SN  CS ] [  0  DD ] [-SN  CS ]
*
*  Arguments
*  =========
*
*  A       (input/output) COMPLEX
*  B       (input/output) COMPLEX
*  C       (input/output) COMPLEX
*  D       (input/output) COMPLEX
*          On entry, the elements of the input matrix.
*          On exit, they are overwritten by the elements of the
*          standardised Schur form.
*
*  RT1     (output) COMPLEX
*  RT2     (output) COMPLEX
*          The two eigenvalues.
*
*  CS      (output) REAL
*  SN      (output) COMPLEX
*          Parameters of the rotation matrix.
*
*  Further Details
*  ===============
*
*  Implemented by Mark R. Fahey, May 28, 1999
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               RZERO, HALF, RONE
      parameter( rzero = 0.0e+0, half = 0.5e+0,
     $                   rone = 1.0e+0 )
      COMPLEX            ZERO, ONE
      parameter( zero = ( 0.0e+0, 0.0e+0 ),
     $                   one = ( 1.0e+0, 0.0e+0 ) )
*     ..
*     .. Local Scalars ..
      COMPLEX            AA, BB, DD, T, TEMP, TEMP2, U, X, Y
      REAL               CR, CI
*     ..
*     .. External Subroutines ..
      EXTERNAL           clartg, sladiv
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          real, cmplx, conjg, aimag, sqrt
*     ..
*     .. Executable Statements ..
*
*     Initialize CS and SN
*
      cs = rone
      sn = zero
*
      IF( c.EQ.zero ) THEN
         GO TO 10
*
      ELSE IF( b.EQ.zero ) THEN
*
*        Swap rows and columns
*
         cs = rzero
         sn = one
         temp = d
         d = a
         a = temp
         b = -c
         c = zero
         GO TO 10
      ELSE IF( ( a-d ).EQ.zero ) THEN
         temp = sqrt( b*c )
         a = a + temp
         d = d - temp
         IF( ( b+c ).EQ.zero ) THEN
            cs = sqrt( half )
            sn = cmplx( rzero, rone )*cs
         ELSE
            temp = sqrt( b+c )
            CALL sladiv( real( sqrt( b ) ), aimag( sqrt( b ) ),
     $                   real( temp ), aimag( temp ), cr, ci )
            temp2 = cmplx( cr, ci )
            cs = real( temp2 )
            CALL sladiv( real( sqrt( c ) ), aimag( sqrt( c ) ),
     $                   real( temp ), aimag( temp ), cr, ci )
            sn = cmplx( cr, ci )
         END IF
         b = b - c
         c = zero
         GO TO 10
      ELSE
*
*        Compute eigenvalue closest to D
*
         t = d
         u = b*c
         x = half*( a-t )
         y = sqrt( x*x+u )
         IF( real( x )*real( y )+aimag( x )*aimag( y ).LT.rzero )
     $      y = -y
         CALL sladiv( real( u ), aimag( u ),
     $                real( x+y ), aimag( x+y ), cr, ci )
         t = t - cmplx( cr, ci )
*
*        Do one QR step with exact shift T - resulting 2 x 2 in
*        triangular form.
*
         CALL clartg( a-t, c, cs, sn, aa )
*
         d = d - t
         bb = cs*b + sn*d
         dd = -conjg( sn )*b + cs*d
*
         a = aa*cs + bb*conjg( sn ) + t
         b = -aa*sn + bb*cs
         c = zero
         d = t
*
      END IF
*
   10 CONTINUE
*
*     Store eigenvalues in RT1 and RT2.
*
      rt1 = a
      rt2 = d
      RETURN
*
*     End of CLANV2
*
      END