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

◆ dlags2()

subroutine dlags2 ( logical  upper,
double precision  a1,
double precision  a2,
double precision  a3,
double precision  b1,
double precision  b2,
double precision  b3,
double precision  csu,
double precision  snu,
double precision  csv,
double precision  snv,
double precision  csq,
double precision  snq 
)

DLAGS2 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 DLAGS2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 DLAGS2 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 DOUBLE PRECISION
[in]A2
          A2 is DOUBLE PRECISION
[in]A3
          A3 is DOUBLE PRECISION
          On entry, A1, A2 and A3 are elements of the input 2-by-2
          upper (lower) triangular matrix A.
[in]B1
          B1 is DOUBLE PRECISION
[in]B2
          B2 is DOUBLE PRECISION
[in]B3
          B3 is DOUBLE PRECISION
          On entry, B1, B2 and B3 are elements of the input 2-by-2
          upper (lower) triangular matrix B.
[out]CSU
          CSU is DOUBLE PRECISION
[out]SNU
          SNU is DOUBLE PRECISION
          The desired orthogonal matrix U.
[out]CSV
          CSV is DOUBLE PRECISION
[out]SNV
          SNV is DOUBLE PRECISION
          The desired orthogonal matrix V.
[out]CSQ
          CSQ is DOUBLE PRECISION
[out]SNQ
          SNQ is DOUBLE PRECISION
          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 dlags2.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 DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
160 $ SNU, SNV
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ZERO
167 parameter( zero = 0.0d+0 )
168* ..
169* .. Local Scalars ..
170 DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
171 $ AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
172 $ SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
173 $ VB11, VB11R, VB12, VB21, VB22, VB22R
174* ..
175* .. External Subroutines ..
176 EXTERNAL dlartg, dlasv2
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 dlasv2( 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 dlartg( -ua11r, ua12, csq, snq, r )
222 ELSE
223 CALL dlartg( -vb11r, vb12, csq, snq, r )
224 END IF
225 ELSE
226 CALL dlartg( -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 dlartg( -ua21, ua22, csq, snq, r )
254 ELSE
255 CALL dlartg( -vb21, vb22, csq, snq, r )
256 END IF
257 ELSE
258 CALL dlartg( -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 dlasv2( 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 dlartg( ua22r, ua21, csq, snq, r )
307 ELSE
308 CALL dlartg( vb22r, vb21, csq, snq, r )
309 END IF
310 ELSE
311 CALL dlartg( 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 dlartg( ua12, ua11, csq, snq, r )
339 ELSE
340 CALL dlartg( vb12, vb11, csq, snq, r )
341 END IF
342 ELSE
343 CALL dlartg( 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 DLAGS2
358*
dlartg
subroutine dlartg(f, g, c, s, r)
DLARTG generates a plane rotation with real cosine and real sine.
Definition dlartg.f90:111
dlasv2
subroutine dlasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition dlasv2.f:136
Here is the call graph for this function:
Here is the caller graph for this function: