dlags2()

subroutine dlags2	(	logical	upper,
		double precision	a1,
		double precision	a2,
		double precision	a3,
		double precision	b1,
		double precision	b2,
		double precision	b3,
		double precision	csu,
		double precision	snu,
		double precision	csv,
		double precision	snv,
		double precision	csq,
		double precision	snq )

DLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such that the rows of the transformed A and B are parallel.

Download DLAGS2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
!> that if ( UPPER ) then
!>
!>           U**T *A*Q = U**T *( A1 A2 )*Q = ( x  0  )
!>                             ( 0  A3 )     ( x  x  )
!> and
!>           V**T*B*Q = V**T *( B1 B2 )*Q = ( x  0  )
!>                            ( 0  B3 )     ( x  x  )
!>
!> or if ( .NOT.UPPER ) then
!>
!>           U**T *A*Q = U**T *( A1 0  )*Q = ( x  x  )
!>                             ( A2 A3 )     ( 0  x  )
!> and
!>           V**T*B*Q = V**T*( B1 0  )*Q = ( x  x  )
!>                           ( B2 B3 )     ( 0  x  )
!>
!> The rows of the transformed A and B are parallel, where
!>
!>   U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
!>       ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
!>
!> Z**T denotes the transpose of Z.
!>
!> 

Parameters

[in]	UPPER	!> UPPER is LOGICAL !> = .TRUE.: the input matrices A and B are upper triangular. !> = .FALSE.: the input matrices A and B are lower triangular. !>
[in]	A1	!> A1 is DOUBLE PRECISION !>
[in]	A2	!> A2 is DOUBLE PRECISION !>
[in]	A3	!> A3 is DOUBLE PRECISION !> On entry, A1, A2 and A3 are elements of the input 2-by-2 !> upper (lower) triangular matrix A. !>
[in]	B1	!> B1 is DOUBLE PRECISION !>
[in]	B2	!> B2 is DOUBLE PRECISION !>
[in]	B3	!> B3 is DOUBLE PRECISION !> On entry, B1, B2 and B3 are elements of the input 2-by-2 !> upper (lower) triangular matrix B. !>
[out]	CSU	!> CSU is DOUBLE PRECISION !>
[out]	SNU	!> SNU is DOUBLE PRECISION !> The desired orthogonal matrix U. !>
[out]	CSV	!> CSV is DOUBLE PRECISION !>
[out]	SNV	!> SNV is DOUBLE PRECISION !> The desired orthogonal matrix V. !>
[out]	CSQ	!> CSQ is DOUBLE PRECISION !>
[out]	SNQ	!> SNQ is DOUBLE PRECISION !> The desired orthogonal matrix Q. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 148 of file dlags2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      LOGICAL            UPPER
      DOUBLE PRECISION   A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
     $                   SNU, SNV
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
     $                   AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
     $                   SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
     $                   VB11, VB11R, VB12, VB21, VB22, VB22R
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlartg, dlasv2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
      IF( upper ) THEN
*
*        Input matrices A and B are upper triangular matrices
*
*        Form matrix C = A*adj(B) = ( a b )
*                                   ( 0 d )
*
         a = a1*b3
         d = a3*b1
         b = a2*b1 - a1*b2
*
*        The SVD of real 2-by-2 triangular C
*
*         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
*         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
*
         CALL dlasv2( a, b, d, s1, s2, snr, csr, snl, csl )
*
         IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
     $        THEN
*
*           Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
*           and (1,2) element of |U|**T *|A| and |V|**T *|B|.
*
            ua11r = csl*a1
            ua12 = csl*a2 + snl*a3
*
            vb11r = csr*b1
            vb12 = csr*b2 + snr*b3
*
            aua12 = abs( csl )*abs( a2 ) + abs( snl )*abs( a3 )
            avb12 = abs( csr )*abs( b2 ) + abs( snr )*abs( b3 )
*
*           zero (1,2) elements of U**T *A and V**T *B
*
            IF( ( abs( ua11r )+abs( ua12 ) ).NE.zero ) THEN
               IF( aua12 / ( abs( ua11r )+abs( ua12 ) ).LE.avb12 /
     $             ( abs( vb11r )+abs( vb12 ) ) ) THEN
                  CALL dlartg( -ua11r, ua12, csq, snq, r )
               ELSE
                  CALL dlartg( -vb11r, vb12, csq, snq, r )
               END IF
            ELSE
               CALL dlartg( -vb11r, vb12, csq, snq, r )
            END IF
*
            csu = csl
            snu = -snl
            csv = csr
            snv = -snr
*
         ELSE
*
*           Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
*           and (2,2) element of |U|**T *|A| and |V|**T *|B|.
*
            ua21 = -snl*a1
            ua22 = -snl*a2 + csl*a3
*
            vb21 = -snr*b1
            vb22 = -snr*b2 + csr*b3
*
            aua22 = abs( snl )*abs( a2 ) + abs( csl )*abs( a3 )
            avb22 = abs( snr )*abs( b2 ) + abs( csr )*abs( b3 )
*
*           zero (2,2) elements of U**T*A and V**T*B, and then swap.
*
            IF( ( abs( ua21 )+abs( ua22 ) ).NE.zero ) THEN
               IF( aua22 / ( abs( ua21 )+abs( ua22 ) ).LE.avb22 /
     $             ( abs( vb21 )+abs( vb22 ) ) ) THEN
                  CALL dlartg( -ua21, ua22, csq, snq, r )
               ELSE
                  CALL dlartg( -vb21, vb22, csq, snq, r )
               END IF
            ELSE
               CALL dlartg( -vb21, vb22, csq, snq, r )
            END IF
*
            csu = snl
            snu = csl
            csv = snr
            snv = csr
*
         END IF
*
      ELSE
*
*        Input matrices A and B are lower triangular matrices
*
*        Form matrix C = A*adj(B) = ( a 0 )
*                                   ( c d )
*
         a = a1*b3
         d = a3*b1
         c = a2*b3 - a3*b2
*
*        The SVD of real 2-by-2 triangular C
*
*         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
*         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
*
         CALL dlasv2( a, c, d, s1, s2, snr, csr, snl, csl )
*
         IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
     $        THEN
*
*           Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
*           and (2,1) element of |U|**T *|A| and |V|**T *|B|.
*
            ua21 = -snr*a1 + csr*a2
            ua22r = csr*a3
*
            vb21 = -snl*b1 + csl*b2
            vb22r = csl*b3
*
            aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs( a2 )
            avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs( b2 )
*
*           zero (2,1) elements of U**T *A and V**T *B.
*
            IF( ( abs( ua21 )+abs( ua22r ) ).NE.zero ) THEN
               IF( aua21 / ( abs( ua21 )+abs( ua22r ) ).LE.avb21 /
     $             ( abs( vb21 )+abs( vb22r ) ) ) THEN
                  CALL dlartg( ua22r, ua21, csq, snq, r )
               ELSE
                  CALL dlartg( vb22r, vb21, csq, snq, r )
               END IF
            ELSE
               CALL dlartg( vb22r, vb21, csq, snq, r )
            END IF
*
            csu = csr
            snu = -snr
            csv = csl
            snv = -snl
*
         ELSE
*
*           Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
*           and (1,1) element of |U|**T *|A| and |V|**T *|B|.
*
            ua11 = csr*a1 + snr*a2
            ua12 = snr*a3
*
            vb11 = csl*b1 + snl*b2
            vb12 = snl*b3
*
            aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs( a2 )
            avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs( b2 )
*
*           zero (1,1) elements of U**T*A and V**T*B, and then swap.
*
            IF( ( abs( ua11 )+abs( ua12 ) ).NE.zero ) THEN
               IF( aua11 / ( abs( ua11 )+abs( ua12 ) ).LE.avb11 /
     $             ( abs( vb11 )+abs( vb12 ) ) ) THEN
                  CALL dlartg( ua12, ua11, csq, snq, r )
               ELSE
                  CALL dlartg( vb12, vb11, csq, snq, r )
               END IF
            ELSE
               CALL dlartg( vb12, vb11, csq, snq, r )
            END IF
*
            csu = snr
            snu = csr
            csv = snl
            snv = csl
*
         END IF
*
      END IF
*
      RETURN
*
*     End of DLAGS2
*

Here is the call graph for this function:

Here is the caller graph for this function: