 LAPACK  3.10.0 LAPACK: Linear Algebra PACKage

◆ zlags2()

 subroutine zlags2 ( logical UPPER, double precision A1, complex*16 A2, double precision A3, double precision B1, complex*16 B2, double precision B3, double precision CSU, complex*16 SNU, double precision CSV, complex*16 SNV, double precision CSQ, complex*16 SNQ )

ZLAGS2

Purpose:
ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such
that if ( UPPER ) then

U**H *A*Q = U**H *( A1 A2 )*Q = ( x  0  )
( 0  A3 )     ( x  x  )
and
V**H*B*Q = V**H *( B1 B2 )*Q = ( x  0  )
( 0  B3 )     ( x  x  )

or if ( .NOT.UPPER ) then

U**H *A*Q = U**H *( A1 0  )*Q = ( x  x  )
( A2 A3 )     ( 0  x  )
and
V**H *B*Q = V**H *( B1 0  )*Q = ( x  x  )
( B2 B3 )     ( 0  x  )
where

U = (   CSU    SNU ), V = (  CSV    SNV ),
( -SNU**H  CSU )      ( -SNV**H CSV )

Q = (   CSQ    SNQ )
( -SNQ**H  CSQ )

The rows of the transformed A and B are parallel. Moreover, if the
input 2-by-2 matrix A is not zero, then the transformed (1,1) entry
of A is not zero. If the input matrices A and B are both not zero,
then the transformed (2,2) element of B is not zero, except when the
first rows of input A and B are parallel and the second rows are
zero.
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 COMPLEX*16 [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 COMPLEX*16 [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 COMPLEX*16 The desired unitary matrix U. [out] CSV CSV is DOUBLE PRECISION [out] SNV SNV is COMPLEX*16 The desired unitary matrix V. [out] CSQ CSQ is DOUBLE PRECISION [out] SNQ SNQ is COMPLEX*16 The desired unitary matrix Q.

Definition at line 156 of file zlags2.f.

158 *
159 * -- LAPACK auxiliary routine --
160 * -- LAPACK is a software package provided by Univ. of Tennessee, --
161 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162 *
163 * .. Scalar Arguments ..
164  LOGICAL UPPER
165  DOUBLE PRECISION A1, A3, B1, B3, CSQ, CSU, CSV
166  COMPLEX*16 A2, B2, SNQ, SNU, SNV
167 * ..
168 *
169 * =====================================================================
170 *
171 * .. Parameters ..
172  DOUBLE PRECISION ZERO, ONE
173  parameter( zero = 0.0d+0, one = 1.0d+0 )
174 * ..
175 * .. Local Scalars ..
176  DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB12, AVB11,
177  \$ AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2,
178  \$ SNL, SNR, UA11R, UA22R, VB11R, VB22R
179  COMPLEX*16 B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11,
180  \$ VB12, VB21, VB22
181 * ..
182 * .. External Subroutines ..
183  EXTERNAL dlasv2, zlartg
184 * ..
185 * .. Intrinsic Functions ..
186  INTRINSIC abs, dble, dcmplx, dconjg, dimag
187 * ..
188 * .. Statement Functions ..
189  DOUBLE PRECISION ABS1
190 * ..
191 * .. Statement Function definitions ..
192  abs1( t ) = abs( dble( t ) ) + abs( dimag( t ) )
193 * ..
194 * .. Executable Statements ..
195 *
196  IF( upper ) THEN
197 *
198 * Input matrices A and B are upper triangular matrices
199 *
200 * Form matrix C = A*adj(B) = ( a b )
201 * ( 0 d )
202 *
203  a = a1*b3
204  d = a3*b1
205  b = a2*b1 - a1*b2
206  fb = abs( b )
207 *
208 * Transform complex 2-by-2 matrix C to real matrix by unitary
209 * diagonal matrix diag(1,D1).
210 *
211  d1 = one
212  IF( fb.NE.zero )
213  \$ d1 = b / fb
214 *
215 * The SVD of real 2 by 2 triangular C
216 *
217 * ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
218 * ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
219 *
220  CALL dlasv2( a, fb, d, s1, s2, snr, csr, snl, csl )
221 *
222  IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
223  \$ THEN
224 *
225 * Compute the (1,1) and (1,2) elements of U**H *A and V**H *B,
226 * and (1,2) element of |U|**H *|A| and |V|**H *|B|.
227 *
228  ua11r = csl*a1
229  ua12 = csl*a2 + d1*snl*a3
230 *
231  vb11r = csr*b1
232  vb12 = csr*b2 + d1*snr*b3
233 *
234  aua12 = abs( csl )*abs1( a2 ) + abs( snl )*abs( a3 )
235  avb12 = abs( csr )*abs1( b2 ) + abs( snr )*abs( b3 )
236 *
237 * zero (1,2) elements of U**H *A and V**H *B
238 *
239  IF( ( abs( ua11r )+abs1( ua12 ) ).EQ.zero ) THEN
240  CALL zlartg( -dcmplx( vb11r ), dconjg( vb12 ), csq, snq,
241  \$ r )
242  ELSE IF( ( abs( vb11r )+abs1( vb12 ) ).EQ.zero ) THEN
243  CALL zlartg( -dcmplx( ua11r ), dconjg( ua12 ), csq, snq,
244  \$ r )
245  ELSE IF( aua12 / ( abs( ua11r )+abs1( ua12 ) ).LE.avb12 /
246  \$ ( abs( vb11r )+abs1( vb12 ) ) ) THEN
247  CALL zlartg( -dcmplx( ua11r ), dconjg( ua12 ), csq, snq,
248  \$ r )
249  ELSE
250  CALL zlartg( -dcmplx( vb11r ), dconjg( vb12 ), csq, snq,
251  \$ r )
252  END IF
253 *
254  csu = csl
255  snu = -d1*snl
256  csv = csr
257  snv = -d1*snr
258 *
259  ELSE
260 *
261 * Compute the (2,1) and (2,2) elements of U**H *A and V**H *B,
262 * and (2,2) element of |U|**H *|A| and |V|**H *|B|.
263 *
264  ua21 = -dconjg( d1 )*snl*a1
265  ua22 = -dconjg( d1 )*snl*a2 + csl*a3
266 *
267  vb21 = -dconjg( d1 )*snr*b1
268  vb22 = -dconjg( d1 )*snr*b2 + csr*b3
269 *
270  aua22 = abs( snl )*abs1( a2 ) + abs( csl )*abs( a3 )
271  avb22 = abs( snr )*abs1( b2 ) + abs( csr )*abs( b3 )
272 *
273 * zero (2,2) elements of U**H *A and V**H *B, and then swap.
274 *
275  IF( ( abs1( ua21 )+abs1( ua22 ) ).EQ.zero ) THEN
276  CALL zlartg( -dconjg( vb21 ), dconjg( vb22 ), csq, snq,
277  \$ r )
278  ELSE IF( ( abs1( vb21 )+abs( vb22 ) ).EQ.zero ) THEN
279  CALL zlartg( -dconjg( ua21 ), dconjg( ua22 ), csq, snq,
280  \$ r )
281  ELSE IF( aua22 / ( abs1( ua21 )+abs1( ua22 ) ).LE.avb22 /
282  \$ ( abs1( vb21 )+abs1( vb22 ) ) ) THEN
283  CALL zlartg( -dconjg( ua21 ), dconjg( ua22 ), csq, snq,
284  \$ r )
285  ELSE
286  CALL zlartg( -dconjg( vb21 ), dconjg( vb22 ), csq, snq,
287  \$ r )
288  END IF
289 *
290  csu = snl
291  snu = d1*csl
292  csv = snr
293  snv = d1*csr
294 *
295  END IF
296 *
297  ELSE
298 *
299 * Input matrices A and B are lower triangular matrices
300 *
301 * Form matrix C = A*adj(B) = ( a 0 )
302 * ( c d )
303 *
304  a = a1*b3
305  d = a3*b1
306  c = a2*b3 - a3*b2
307  fc = abs( c )
308 *
309 * Transform complex 2-by-2 matrix C to real matrix by unitary
310 * diagonal matrix diag(d1,1).
311 *
312  d1 = one
313  IF( fc.NE.zero )
314  \$ d1 = c / fc
315 *
316 * The SVD of real 2 by 2 triangular C
317 *
318 * ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
319 * ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
320 *
321  CALL dlasv2( a, fc, d, s1, s2, snr, csr, snl, csl )
322 *
323  IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
324  \$ THEN
325 *
326 * Compute the (2,1) and (2,2) elements of U**H *A and V**H *B,
327 * and (2,1) element of |U|**H *|A| and |V|**H *|B|.
328 *
329  ua21 = -d1*snr*a1 + csr*a2
330  ua22r = csr*a3
331 *
332  vb21 = -d1*snl*b1 + csl*b2
333  vb22r = csl*b3
334 *
335  aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs1( a2 )
336  avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 )
337 *
338 * zero (2,1) elements of U**H *A and V**H *B.
339 *
340  IF( ( abs1( ua21 )+abs( ua22r ) ).EQ.zero ) THEN
341  CALL zlartg( dcmplx( vb22r ), vb21, csq, snq, r )
342  ELSE IF( ( abs1( vb21 )+abs( vb22r ) ).EQ.zero ) THEN
343  CALL zlartg( dcmplx( ua22r ), ua21, csq, snq, r )
344  ELSE IF( aua21 / ( abs1( ua21 )+abs( ua22r ) ).LE.avb21 /
345  \$ ( abs1( vb21 )+abs( vb22r ) ) ) THEN
346  CALL zlartg( dcmplx( ua22r ), ua21, csq, snq, r )
347  ELSE
348  CALL zlartg( dcmplx( vb22r ), vb21, csq, snq, r )
349  END IF
350 *
351  csu = csr
352  snu = -dconjg( d1 )*snr
353  csv = csl
354  snv = -dconjg( d1 )*snl
355 *
356  ELSE
357 *
358 * Compute the (1,1) and (1,2) elements of U**H *A and V**H *B,
359 * and (1,1) element of |U|**H *|A| and |V|**H *|B|.
360 *
361  ua11 = csr*a1 + dconjg( d1 )*snr*a2
362  ua12 = dconjg( d1 )*snr*a3
363 *
364  vb11 = csl*b1 + dconjg( d1 )*snl*b2
365  vb12 = dconjg( d1 )*snl*b3
366 *
367  aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs1( a2 )
368  avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 )
369 *
370 * zero (1,1) elements of U**H *A and V**H *B, and then swap.
371 *
372  IF( ( abs1( ua11 )+abs1( ua12 ) ).EQ.zero ) THEN
373  CALL zlartg( vb12, vb11, csq, snq, r )
374  ELSE IF( ( abs1( vb11 )+abs1( vb12 ) ).EQ.zero ) THEN
375  CALL zlartg( ua12, ua11, csq, snq, r )
376  ELSE IF( aua11 / ( abs1( ua11 )+abs1( ua12 ) ).LE.avb11 /
377  \$ ( abs1( vb11 )+abs1( vb12 ) ) ) THEN
378  CALL zlartg( ua12, ua11, csq, snq, r )
379  ELSE
380  CALL zlartg( vb12, vb11, csq, snq, r )
381  END IF
382 *
383  csu = snr
384  snu = dconjg( d1 )*csr
385  csv = snl
386  snv = dconjg( d1 )*csl
387 *
388  END IF
389 *
390  END IF
391 *
392  RETURN
393 *
394 * End of ZLAGS2
395 *
subroutine zlartg(f, g, c, s, r)
ZLARTG generates a plane rotation with real cosine and complex sine.
Definition: zlartg.f90:118
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: