LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ slags2()

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.

Download SLAGS2 + dependencies [TGZ] [ZIP] [TXT]

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.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file slags2.f.

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*
slartg
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition slartg.f90:111
slasv2
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:136
Here is the call graph for this function:
Here is the caller graph for this function: