LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ 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.
Date
December 2016

Definition at line 154 of file dlags2.f.

154 *
155 * -- LAPACK auxiliary routine (version 3.7.0) --
156 * -- LAPACK is a software package provided by Univ. of Tennessee, --
157 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
158 * December 2016
159 *
160 * .. Scalar Arguments ..
161  LOGICAL upper
162  DOUBLE PRECISION a1, a2, a3, b1, b2, b3, csq, csu, csv, snq,
163  $ snu, snv
164 * ..
165 *
166 * =====================================================================
167 *
168 * .. Parameters ..
169  DOUBLE PRECISION zero
170  parameter( zero = 0.0d+0 )
171 * ..
172 * .. Local Scalars ..
173  DOUBLE PRECISION a, aua11, aua12, aua21, aua22, avb11, avb12,
174  $ avb21, avb22, b, c, csl, csr, d, r, s1, s2,
175  $ snl, snr, ua11, ua11r, ua12, ua21, ua22, ua22r,
176  $ vb11, vb11r, vb12, vb21, vb22, vb22r
177 * ..
178 * .. External Subroutines ..
179  EXTERNAL dlartg, dlasv2
180 * ..
181 * .. Intrinsic Functions ..
182  INTRINSIC abs
183 * ..
184 * .. Executable Statements ..
185 *
186  IF( upper ) THEN
187 *
188 * Input matrices A and B are upper triangular matrices
189 *
190 * Form matrix C = A*adj(B) = ( a b )
191 * ( 0 d )
192 *
193  a = a1*b3
194  d = a3*b1
195  b = a2*b1 - a1*b2
196 *
197 * The SVD of real 2-by-2 triangular C
198 *
199 * ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
200 * ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
201 *
202  CALL dlasv2( a, b, d, s1, s2, snr, csr, snl, csl )
203 *
204  IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
205  $ THEN
206 *
207 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
208 * and (1,2) element of |U|**T *|A| and |V|**T *|B|.
209 *
210  ua11r = csl*a1
211  ua12 = csl*a2 + snl*a3
212 *
213  vb11r = csr*b1
214  vb12 = csr*b2 + snr*b3
215 *
216  aua12 = abs( csl )*abs( a2 ) + abs( snl )*abs( a3 )
217  avb12 = abs( csr )*abs( b2 ) + abs( snr )*abs( b3 )
218 *
219 * zero (1,2) elements of U**T *A and V**T *B
220 *
221  IF( ( abs( ua11r )+abs( ua12 ) ).NE.zero ) THEN
222  IF( aua12 / ( abs( ua11r )+abs( ua12 ) ).LE.avb12 /
223  $ ( abs( vb11r )+abs( vb12 ) ) ) THEN
224  CALL dlartg( -ua11r, ua12, csq, snq, r )
225  ELSE
226  CALL dlartg( -vb11r, vb12, csq, snq, r )
227  END IF
228  ELSE
229  CALL dlartg( -vb11r, vb12, csq, snq, r )
230  END IF
231 *
232  csu = csl
233  snu = -snl
234  csv = csr
235  snv = -snr
236 *
237  ELSE
238 *
239 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
240 * and (2,2) element of |U|**T *|A| and |V|**T *|B|.
241 *
242  ua21 = -snl*a1
243  ua22 = -snl*a2 + csl*a3
244 *
245  vb21 = -snr*b1
246  vb22 = -snr*b2 + csr*b3
247 *
248  aua22 = abs( snl )*abs( a2 ) + abs( csl )*abs( a3 )
249  avb22 = abs( snr )*abs( b2 ) + abs( csr )*abs( b3 )
250 *
251 * zero (2,2) elements of U**T*A and V**T*B, and then swap.
252 *
253  IF( ( abs( ua21 )+abs( ua22 ) ).NE.zero ) THEN
254  IF( aua22 / ( abs( ua21 )+abs( ua22 ) ).LE.avb22 /
255  $ ( abs( vb21 )+abs( vb22 ) ) ) THEN
256  CALL dlartg( -ua21, ua22, csq, snq, r )
257  ELSE
258  CALL dlartg( -vb21, vb22, csq, snq, r )
259  END IF
260  ELSE
261  CALL dlartg( -vb21, vb22, csq, snq, r )
262  END IF
263 *
264  csu = snl
265  snu = csl
266  csv = snr
267  snv = csr
268 *
269  END IF
270 *
271  ELSE
272 *
273 * Input matrices A and B are lower triangular matrices
274 *
275 * Form matrix C = A*adj(B) = ( a 0 )
276 * ( c d )
277 *
278  a = a1*b3
279  d = a3*b1
280  c = a2*b3 - a3*b2
281 *
282 * The SVD of real 2-by-2 triangular C
283 *
284 * ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
285 * ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
286 *
287  CALL dlasv2( a, c, d, s1, s2, snr, csr, snl, csl )
288 *
289  IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
290  $ THEN
291 *
292 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
293 * and (2,1) element of |U|**T *|A| and |V|**T *|B|.
294 *
295  ua21 = -snr*a1 + csr*a2
296  ua22r = csr*a3
297 *
298  vb21 = -snl*b1 + csl*b2
299  vb22r = csl*b3
300 *
301  aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs( a2 )
302  avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs( b2 )
303 *
304 * zero (2,1) elements of U**T *A and V**T *B.
305 *
306  IF( ( abs( ua21 )+abs( ua22r ) ).NE.zero ) THEN
307  IF( aua21 / ( abs( ua21 )+abs( ua22r ) ).LE.avb21 /
308  $ ( abs( vb21 )+abs( vb22r ) ) ) THEN
309  CALL dlartg( ua22r, ua21, csq, snq, r )
310  ELSE
311  CALL dlartg( vb22r, vb21, csq, snq, r )
312  END IF
313  ELSE
314  CALL dlartg( vb22r, vb21, csq, snq, r )
315  END IF
316 *
317  csu = csr
318  snu = -snr
319  csv = csl
320  snv = -snl
321 *
322  ELSE
323 *
324 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
325 * and (1,1) element of |U|**T *|A| and |V|**T *|B|.
326 *
327  ua11 = csr*a1 + snr*a2
328  ua12 = snr*a3
329 *
330  vb11 = csl*b1 + snl*b2
331  vb12 = snl*b3
332 *
333  aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs( a2 )
334  avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs( b2 )
335 *
336 * zero (1,1) elements of U**T*A and V**T*B, and then swap.
337 *
338  IF( ( abs( ua11 )+abs( ua12 ) ).NE.zero ) THEN
339  IF( aua11 / ( abs( ua11 )+abs( ua12 ) ).LE.avb11 /
340  $ ( abs( vb11 )+abs( vb12 ) ) ) THEN
341  CALL dlartg( ua12, ua11, csq, snq, r )
342  ELSE
343  CALL dlartg( vb12, vb11, csq, snq, r )
344  END IF
345  ELSE
346  CALL dlartg( vb12, vb11, csq, snq, r )
347  END IF
348 *
349  csu = snr
350  snu = csr
351  csv = snl
352  snv = csl
353 *
354  END IF
355 *
356  END IF
357 *
358  RETURN
359 *
360 * End of DLAGS2
361 *
subroutine dlartg(F, G, CS, SN, R)
DLARTG generates a plane rotation with real cosine and real sine.
Definition: dlartg.f:99
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:140
Here is the call graph for this function:
Here is the caller graph for this function: