LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
slags2.f
Go to the documentation of this file.
1 *> \brief \b 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.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download SLAGS2 + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slags2.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slags2.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slags2.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
22 * SNV, CSQ, SNQ )
23 *
24 * .. Scalar Arguments ..
25 * LOGICAL UPPER
26 * REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
27 * $ SNU, SNV
28 * ..
29 *
30 *
31 *> \par Purpose:
32 * =============
33 *>
34 *> \verbatim
35 *>
36 *> SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
37 *> that if ( UPPER ) then
38 *>
39 *> U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 )
40 *> ( 0 A3 ) ( x x )
41 *> and
42 *> V**T*B*Q = V**T *( B1 B2 )*Q = ( x 0 )
43 *> ( 0 B3 ) ( x x )
44 *>
45 *> or if ( .NOT.UPPER ) then
46 *>
47 *> U**T *A*Q = U**T *( A1 0 )*Q = ( x x )
48 *> ( A2 A3 ) ( 0 x )
49 *> and
50 *> V**T*B*Q = V**T*( B1 0 )*Q = ( x x )
51 *> ( B2 B3 ) ( 0 x )
52 *>
53 *> The rows of the transformed A and B are parallel, where
54 *>
55 *> U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )
56 *> ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )
57 *>
58 *> Z**T denotes the transpose of Z.
59 *>
60 *> \endverbatim
61 *
62 * Arguments:
63 * ==========
64 *
65 *> \param[in] UPPER
66 *> \verbatim
67 *> UPPER is LOGICAL
68 *> = .TRUE.: the input matrices A and B are upper triangular.
69 *> = .FALSE.: the input matrices A and B are lower triangular.
70 *> \endverbatim
71 *>
72 *> \param[in] A1
73 *> \verbatim
74 *> A1 is REAL
75 *> \endverbatim
76 *>
77 *> \param[in] A2
78 *> \verbatim
79 *> A2 is REAL
80 *> \endverbatim
81 *>
82 *> \param[in] A3
83 *> \verbatim
84 *> A3 is REAL
85 *> On entry, A1, A2 and A3 are elements of the input 2-by-2
86 *> upper (lower) triangular matrix A.
87 *> \endverbatim
88 *>
89 *> \param[in] B1
90 *> \verbatim
91 *> B1 is REAL
92 *> \endverbatim
93 *>
94 *> \param[in] B2
95 *> \verbatim
96 *> B2 is REAL
97 *> \endverbatim
98 *>
99 *> \param[in] B3
100 *> \verbatim
101 *> B3 is REAL
102 *> On entry, B1, B2 and B3 are elements of the input 2-by-2
103 *> upper (lower) triangular matrix B.
104 *> \endverbatim
105 *>
106 *> \param[out] CSU
107 *> \verbatim
108 *> CSU is REAL
109 *> \endverbatim
110 *>
111 *> \param[out] SNU
112 *> \verbatim
113 *> SNU is REAL
114 *> The desired orthogonal matrix U.
115 *> \endverbatim
116 *>
117 *> \param[out] CSV
118 *> \verbatim
119 *> CSV is REAL
120 *> \endverbatim
121 *>
122 *> \param[out] SNV
123 *> \verbatim
124 *> SNV is REAL
125 *> The desired orthogonal matrix V.
126 *> \endverbatim
127 *>
128 *> \param[out] CSQ
129 *> \verbatim
130 *> CSQ is REAL
131 *> \endverbatim
132 *>
133 *> \param[out] SNQ
134 *> \verbatim
135 *> SNQ is REAL
136 *> The desired orthogonal matrix Q.
137 *> \endverbatim
138 *
139 * Authors:
140 * ========
141 *
142 *> \author Univ. of Tennessee
143 *> \author Univ. of California Berkeley
144 *> \author Univ. of Colorado Denver
145 *> \author NAG Ltd.
146 *
147 *> \ingroup realOTHERauxiliary
148 *
149 * =====================================================================
150  SUBROUTINE slags2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
151  $ SNV, CSQ, SNQ )
152 *
153 * -- LAPACK auxiliary routine --
154 * -- LAPACK is a software package provided by Univ. of Tennessee, --
155 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156 *
157 * .. Scalar Arguments ..
158  LOGICAL UPPER
159  REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
160  $ snu, snv
161 * ..
162 *
163 * =====================================================================
164 *
165 * .. Parameters ..
166  REAL ZERO
167  parameter( zero = 0.0e+0 )
168 * ..
169 * .. Local Scalars ..
170  REAL A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
171  $ avb21, avb22, csl, csr, d, s1, s2, snl,
172  $ snr, ua11r, ua22r, vb11r, vb22r, b, c, r, ua11,
173  $ ua12, ua21, ua22, vb11, vb12, vb21, vb22
174 * ..
175 * .. External Subroutines ..
176  EXTERNAL slartg, slasv2
177 * ..
178 * .. Intrinsic Functions ..
179  INTRINSIC abs
180 * ..
181 * .. Executable Statements ..
182 *
183  IF( upper ) THEN
184 *
185 * Input matrices A and B are upper triangular matrices
186 *
187 * Form matrix C = A*adj(B) = ( a b )
188 * ( 0 d )
189 *
190  a = a1*b3
191  d = a3*b1
192  b = a2*b1 - a1*b2
193 *
194 * The SVD of real 2-by-2 triangular C
195 *
196 * ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
197 * ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
198 *
199  CALL slasv2( a, b, d, s1, s2, snr, csr, snl, csl )
200 *
201  IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
202  $ THEN
203 *
204 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
205 * and (1,2) element of |U|**T *|A| and |V|**T *|B|.
206 *
207  ua11r = csl*a1
208  ua12 = csl*a2 + snl*a3
209 *
210  vb11r = csr*b1
211  vb12 = csr*b2 + snr*b3
212 *
213  aua12 = abs( csl )*abs( a2 ) + abs( snl )*abs( a3 )
214  avb12 = abs( csr )*abs( b2 ) + abs( snr )*abs( b3 )
215 *
216 * zero (1,2) elements of U**T *A and V**T *B
217 *
218  IF( ( abs( ua11r )+abs( ua12 ) ).NE.zero ) THEN
219  IF( aua12 / ( abs( ua11r )+abs( ua12 ) ).LE.avb12 /
220  $ ( abs( vb11r )+abs( vb12 ) ) ) THEN
221  CALL slartg( -ua11r, ua12, csq, snq, r )
222  ELSE
223  CALL slartg( -vb11r, vb12, csq, snq, r )
224  END IF
225  ELSE
226  CALL slartg( -vb11r, vb12, csq, snq, r )
227  END IF
228 *
229  csu = csl
230  snu = -snl
231  csv = csr
232  snv = -snr
233 *
234  ELSE
235 *
236 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
237 * and (2,2) element of |U|**T *|A| and |V|**T *|B|.
238 *
239  ua21 = -snl*a1
240  ua22 = -snl*a2 + csl*a3
241 *
242  vb21 = -snr*b1
243  vb22 = -snr*b2 + csr*b3
244 *
245  aua22 = abs( snl )*abs( a2 ) + abs( csl )*abs( a3 )
246  avb22 = abs( snr )*abs( b2 ) + abs( csr )*abs( b3 )
247 *
248 * zero (2,2) elements of U**T*A and V**T*B, and then swap.
249 *
250  IF( ( abs( ua21 )+abs( ua22 ) ).NE.zero ) THEN
251  IF( aua22 / ( abs( ua21 )+abs( ua22 ) ).LE.avb22 /
252  $ ( abs( vb21 )+abs( vb22 ) ) ) THEN
253  CALL slartg( -ua21, ua22, csq, snq, r )
254  ELSE
255  CALL slartg( -vb21, vb22, csq, snq, r )
256  END IF
257  ELSE
258  CALL slartg( -vb21, vb22, csq, snq, r )
259  END IF
260 *
261  csu = snl
262  snu = csl
263  csv = snr
264  snv = csr
265 *
266  END IF
267 *
268  ELSE
269 *
270 * Input matrices A and B are lower triangular matrices
271 *
272 * Form matrix C = A*adj(B) = ( a 0 )
273 * ( c d )
274 *
275  a = a1*b3
276  d = a3*b1
277  c = a2*b3 - a3*b2
278 *
279 * The SVD of real 2-by-2 triangular C
280 *
281 * ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
282 * ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
283 *
284  CALL slasv2( a, c, d, s1, s2, snr, csr, snl, csl )
285 *
286  IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
287  $ THEN
288 *
289 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
290 * and (2,1) element of |U|**T *|A| and |V|**T *|B|.
291 *
292  ua21 = -snr*a1 + csr*a2
293  ua22r = csr*a3
294 *
295  vb21 = -snl*b1 + csl*b2
296  vb22r = csl*b3
297 *
298  aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs( a2 )
299  avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs( b2 )
300 *
301 * zero (2,1) elements of U**T *A and V**T *B.
302 *
303  IF( ( abs( ua21 )+abs( ua22r ) ).NE.zero ) THEN
304  IF( aua21 / ( abs( ua21 )+abs( ua22r ) ).LE.avb21 /
305  $ ( abs( vb21 )+abs( vb22r ) ) ) THEN
306  CALL slartg( ua22r, ua21, csq, snq, r )
307  ELSE
308  CALL slartg( vb22r, vb21, csq, snq, r )
309  END IF
310  ELSE
311  CALL slartg( vb22r, vb21, csq, snq, r )
312  END IF
313 *
314  csu = csr
315  snu = -snr
316  csv = csl
317  snv = -snl
318 *
319  ELSE
320 *
321 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
322 * and (1,1) element of |U|**T *|A| and |V|**T *|B|.
323 *
324  ua11 = csr*a1 + snr*a2
325  ua12 = snr*a3
326 *
327  vb11 = csl*b1 + snl*b2
328  vb12 = snl*b3
329 *
330  aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs( a2 )
331  avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs( b2 )
332 *
333 * zero (1,1) elements of U**T*A and V**T*B, and then swap.
334 *
335  IF( ( abs( ua11 )+abs( ua12 ) ).NE.zero ) THEN
336  IF( aua11 / ( abs( ua11 )+abs( ua12 ) ).LE.avb11 /
337  $ ( abs( vb11 )+abs( vb12 ) ) ) THEN
338  CALL slartg( ua12, ua11, csq, snq, r )
339  ELSE
340  CALL slartg( vb12, vb11, csq, snq, r )
341  END IF
342  ELSE
343  CALL slartg( vb12, vb11, csq, snq, r )
344  END IF
345 *
346  csu = snr
347  snu = csr
348  csv = snl
349  snv = csl
350 *
351  END IF
352 *
353  END IF
354 *
355  RETURN
356 *
357 * End of SLAGS2
358 *
359  END
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:138
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition: slartg.f90:113
subroutine slags2(UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ)
SLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such tha...
Definition: slags2.f:152