LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine slags2 ( logical  UPPER,
real  A1,
real  A2,
real  A3,
real  B1,
real  B2,
real  B3,
real  CSU,
real  SNU,
real  CSV,
real  SNV,
real  CSQ,
real  SNQ 
)

SLAGS2 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 SLAGS2 + dependencies [TGZ] [ZIP] [TXT]

Purpose: 
 SLAGS2 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 REAL
[in]A2
          A2 is REAL
[in]A3
          A3 is REAL
          On entry, A1, A2 and A3 are elements of the input 2-by-2
          upper (lower) triangular matrix A.
[in]B1
          B1 is REAL
[in]B2
          B2 is REAL
[in]B3
          B3 is REAL
          On entry, B1, B2 and B3 are elements of the input 2-by-2
          upper (lower) triangular matrix B.
[out]CSU
          CSU is REAL
[out]SNU
          SNU is REAL
          The desired orthogonal matrix U.
[out]CSV
          CSV is REAL
[out]SNV
          SNV is REAL
          The desired orthogonal matrix V.
[out]CSQ
          CSQ is REAL
[out]SNQ
          SNQ is REAL
          The desired orthogonal matrix Q.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
September 2012

Definition at line 154 of file slags2.f.

154 *
155 * -- LAPACK auxiliary routine (version 3.4.2) --
156 * -- LAPACK is a software package provided by Univ. of Tennessee, --
157 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
158 * September 2012
159 *
160 * .. Scalar Arguments ..
161  LOGICAL upper
162  REAL a1, a2, a3, b1, b2, b3, csq, csu, csv, snq,
163  $ snu, snv
164 * ..
165 *
166 * =====================================================================
167 *
168 * .. Parameters ..
169  REAL zero
170  parameter ( zero = 0.0e+0 )
171 * ..
172 * .. Local Scalars ..
173  REAL a, aua11, aua12, aua21, aua22, avb11, avb12,
174  $ avb21, avb22, csl, csr, d, s1, s2, snl,
175  $ snr, ua11r, ua22r, vb11r, vb22r, b, c, r, ua11,
176  $ ua12, ua21, ua22, vb11, vb12, vb21, vb22
177 * ..
178 * .. External Subroutines ..
179  EXTERNAL slartg, slasv2
180 * ..
181 * .. Intrinsic Functions ..
182  INTRINSIC abs
183 * ..
184 * .. Executable Statements ..
185 *
186  IF( upper ) THEN
187 *
188 * Input matrices A and B are upper triangular matrices
189 *
190 * Form matrix C = A*adj(B) = ( a b )
191 * ( 0 d )
192 *
193  a = a1*b3
194  d = a3*b1
195  b = a2*b1 - a1*b2
196 *
197 * The SVD of real 2-by-2 triangular C
198 *
199 * ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
200 * ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
201 *
202  CALL slasv2( a, b, d, s1, s2, snr, csr, snl, csl )
203 *
204  IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
205  $ THEN
206 *
207 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
208 * and (1,2) element of |U|**T *|A| and |V|**T *|B|.
209 *
210  ua11r = csl*a1
211  ua12 = csl*a2 + snl*a3
212 *
213  vb11r = csr*b1
214  vb12 = csr*b2 + snr*b3
215 *
216  aua12 = abs( csl )*abs( a2 ) + abs( snl )*abs( a3 )
217  avb12 = abs( csr )*abs( b2 ) + abs( snr )*abs( b3 )
218 *
219 * zero (1,2) elements of U**T *A and V**T *B
220 *
221  IF( ( abs( ua11r )+abs( ua12 ) ).NE.zero ) THEN
222  IF( aua12 / ( abs( ua11r )+abs( ua12 ) ).LE.avb12 /
223  $ ( abs( vb11r )+abs( vb12 ) ) ) THEN
224  CALL slartg( -ua11r, ua12, csq, snq, r )
225  ELSE
226  CALL slartg( -vb11r, vb12, csq, snq, r )
227  END IF
228  ELSE
229  CALL slartg( -vb11r, vb12, csq, snq, r )
230  END IF
231 *
232  csu = csl
233  snu = -snl
234  csv = csr
235  snv = -snr
236 *
237  ELSE
238 *
239 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
240 * and (2,2) element of |U|**T *|A| and |V|**T *|B|.
241 *
242  ua21 = -snl*a1
243  ua22 = -snl*a2 + csl*a3
244 *
245  vb21 = -snr*b1
246  vb22 = -snr*b2 + csr*b3
247 *
248  aua22 = abs( snl )*abs( a2 ) + abs( csl )*abs( a3 )
249  avb22 = abs( snr )*abs( b2 ) + abs( csr )*abs( b3 )
250 *
251 * zero (2,2) elements of U**T*A and V**T*B, and then swap.
252 *
253  IF( ( abs( ua21 )+abs( ua22 ) ).NE.zero ) THEN
254  IF( aua22 / ( abs( ua21 )+abs( ua22 ) ).LE.avb22 /
255  $ ( abs( vb21 )+abs( vb22 ) ) ) THEN
256  CALL slartg( -ua21, ua22, csq, snq, r )
257  ELSE
258  CALL slartg( -vb21, vb22, csq, snq, r )
259  END IF
260  ELSE
261  CALL slartg( -vb21, vb22, csq, snq, r )
262  END IF
263 *
264  csu = snl
265  snu = csl
266  csv = snr
267  snv = csr
268 *
269  END IF
270 *
271  ELSE
272 *
273 * Input matrices A and B are lower triangular matrices
274 *
275 * Form matrix C = A*adj(B) = ( a 0 )
276 * ( c d )
277 *
278  a = a1*b3
279  d = a3*b1
280  c = a2*b3 - a3*b2
281 *
282 * The SVD of real 2-by-2 triangular C
283 *
284 * ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
285 * ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
286 *
287  CALL slasv2( a, c, d, s1, s2, snr, csr, snl, csl )
288 *
289  IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
290  $ THEN
291 *
292 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
293 * and (2,1) element of |U|**T *|A| and |V|**T *|B|.
294 *
295  ua21 = -snr*a1 + csr*a2
296  ua22r = csr*a3
297 *
298  vb21 = -snl*b1 + csl*b2
299  vb22r = csl*b3
300 *
301  aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs( a2 )
302  avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs( b2 )
303 *
304 * zero (2,1) elements of U**T *A and V**T *B.
305 *
306  IF( ( abs( ua21 )+abs( ua22r ) ).NE.zero ) THEN
307  IF( aua21 / ( abs( ua21 )+abs( ua22r ) ).LE.avb21 /
308  $ ( abs( vb21 )+abs( vb22r ) ) ) THEN
309  CALL slartg( ua22r, ua21, csq, snq, r )
310  ELSE
311  CALL slartg( vb22r, vb21, csq, snq, r )
312  END IF
313  ELSE
314  CALL slartg( vb22r, vb21, csq, snq, r )
315  END IF
316 *
317  csu = csr
318  snu = -snr
319  csv = csl
320  snv = -snl
321 *
322  ELSE
323 *
324 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
325 * and (1,1) element of |U|**T *|A| and |V|**T *|B|.
326 *
327  ua11 = csr*a1 + snr*a2
328  ua12 = snr*a3
329 *
330  vb11 = csl*b1 + snl*b2
331  vb12 = snl*b3
332 *
333  aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs( a2 )
334  avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs( b2 )
335 *
336 * zero (1,1) elements of U**T*A and V**T*B, and then swap.
337 *
338  IF( ( abs( ua11 )+abs( ua12 ) ).NE.zero ) THEN
339  IF( aua11 / ( abs( ua11 )+abs( ua12 ) ).LE.avb11 /
340  $ ( abs( vb11 )+abs( vb12 ) ) ) THEN
341  CALL slartg( ua12, ua11, csq, snq, r )
342  ELSE
343  CALL slartg( vb12, vb11, csq, snq, r )
344  END IF
345  ELSE
346  CALL slartg( vb12, vb11, csq, snq, r )
347  END IF
348 *
349  csu = snr
350  snu = csr
351  csv = snl
352  snv = csl
353 *
354  END IF
355 *
356  END IF
357 *
358  RETURN
359 *
360 * End of SLAGS2
361 *
slartg
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
Definition: slartg.f:99
slasv2
subroutine slasv2(F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL)
SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition: slasv2.f:140

Here is the call graph for this function:

Here is the caller graph for this function: