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

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

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*
zlartg
subroutine zlartg(f, g, c, s, r)
ZLARTG generates a plane rotation with real cosine and complex sine.
Definition zlartg.f90:116
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: