LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches
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
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:111
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