LAPACK  3.10.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.

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.```

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