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