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.

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.```
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 *
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
Definition: slartg.f:99
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: