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

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

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

Definition at line 160 of file zlags2.f.

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