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