158 SUBROUTINE clags2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
168 REAL A1, A3, B1, B3, CSQ, CSU, CSV
169 COMPLEX A2, B2, SNQ, SNU, SNV
176 parameter ( zero = 0.0e+0, one = 1.0e+0 )
179 REAL A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
180 $ avb21, avb22, csl, csr, d, fb, fc, s1, s2, snl,
181 $ snr, ua11r, ua22r, vb11r, vb22r
182 COMPLEX B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11,
189 INTRINSIC abs, aimag, cmplx, conjg, real
195 abs1( t ) = abs(
REAL( T ) ) + abs( AIMAG( t ) )
223 CALL slasv2( a, fb, d, s1, s2, snr, csr, snl, csl )
225 IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
232 ua12 = csl*a2 + d1*snl*a3
235 vb12 = csr*b2 + d1*snr*b3
237 aua12 = abs( csl )*abs1( a2 ) + abs( snl )*abs( a3 )
238 avb12 = abs( csr )*abs1( b2 ) + abs( snr )*abs( b3 )
242 IF( ( abs( ua11r )+abs1( ua12 ) ).EQ.zero )
THEN
243 CALL clartg( -cmplx( vb11r ), conjg( vb12 ), csq, snq,
245 ELSE IF( ( abs( vb11r )+abs1( vb12 ) ).EQ.zero )
THEN
246 CALL clartg( -cmplx( ua11r ), conjg( ua12 ), csq, snq,
248 ELSE IF( aua12 / ( abs( ua11r )+abs1( ua12 ) ).LE.avb12 /
249 $ ( abs( vb11r )+abs1( vb12 ) ) )
THEN
250 CALL clartg( -cmplx( ua11r ), conjg( ua12 ), csq, snq,
253 CALL clartg( -cmplx( vb11r ), conjg( vb12 ), csq, snq,
267 ua21 = -conjg( d1 )*snl*a1
268 ua22 = -conjg( d1 )*snl*a2 + csl*a3
270 vb21 = -conjg( d1 )*snr*b1
271 vb22 = -conjg( d1 )*snr*b2 + csr*b3
273 aua22 = abs( snl )*abs1( a2 ) + abs( csl )*abs( a3 )
274 avb22 = abs( snr )*abs1( b2 ) + abs( csr )*abs( b3 )
278 IF( ( abs1( ua21 )+abs1( ua22 ) ).EQ.zero )
THEN
279 CALL clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r )
280 ELSE IF( ( abs1( vb21 )+abs( vb22 ) ).EQ.zero )
THEN
281 CALL clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r )
282 ELSE IF( aua22 / ( abs1( ua21 )+abs1( ua22 ) ).LE.avb22 /
283 $ ( abs1( vb21 )+abs1( vb22 ) ) )
THEN
284 CALL clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r )
286 CALL clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r )
320 CALL slasv2( a, fc, d, s1, s2, snr, csr, snl, csl )
322 IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
328 ua21 = -d1*snr*a1 + csr*a2
331 vb21 = -d1*snl*b1 + csl*b2
334 aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs1( a2 )
335 avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 )
339 IF( ( abs1( ua21 )+abs( ua22r ) ).EQ.zero )
THEN
340 CALL clartg( cmplx( vb22r ), vb21, csq, snq, r )
341 ELSE IF( ( abs1( vb21 )+abs( vb22r ) ).EQ.zero )
THEN
342 CALL clartg( cmplx( ua22r ), ua21, csq, snq, r )
343 ELSE IF( aua21 / ( abs1( ua21 )+abs( ua22r ) ).LE.avb21 /
344 $ ( abs1( vb21 )+abs( vb22r ) ) )
THEN
345 CALL clartg( cmplx( ua22r ), ua21, csq, snq, r )
347 CALL clartg( cmplx( vb22r ), vb21, csq, snq, r )
351 snu = -conjg( d1 )*snr
353 snv = -conjg( d1 )*snl
360 ua11 = csr*a1 + conjg( d1 )*snr*a2
361 ua12 = conjg( d1 )*snr*a3
363 vb11 = csl*b1 + conjg( d1 )*snl*b2
364 vb12 = conjg( d1 )*snl*b3
366 aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs1( a2 )
367 avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 )
371 IF( ( abs1( ua11 )+abs1( ua12 ) ).EQ.zero )
THEN
372 CALL clartg( vb12, vb11, csq, snq, r )
373 ELSE IF( ( abs1( vb11 )+abs1( vb12 ) ).EQ.zero )
THEN
374 CALL clartg( ua12, ua11, csq, snq, r )
375 ELSE IF( aua11 / ( abs1( ua11 )+abs1( ua12 ) ).LE.avb11 /
376 $ ( abs1( vb11 )+abs1( vb12 ) ) )
THEN
377 CALL clartg( ua12, ua11, csq, snq, r )
379 CALL clartg( vb12, vb11, csq, snq, r )
383 snu = conjg( d1 )*csr
385 snv = conjg( d1 )*csl
subroutine clartg(F, G, CS, SN, R)
CLARTG generates a plane rotation with real cosine and complex sine.
subroutine clags2(UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ)
CLAGS2
subroutine slasv2(F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL)
SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.