172 SUBROUTINE zlatm6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
173 $ BETA, WX, WY, S, DIF )
180 INTEGER LDA, LDX, LDY, N, TYPE
181 COMPLEX*16 ALPHA, BETA, WX, WY
184 DOUBLE PRECISION DIF( * ), S( * )
185 COMPLEX*16 A( LDA, * ), B( LDA, * ), X( LDX, * ),
192 DOUBLE PRECISION RONE, TWO, THREE
193 parameter( rone = 1.0d+0, two = 2.0d+0, three = 3.0d+0 )
195 parameter( zero = ( 0.0d+0, 0.0d+0 ),
196 $ one = ( 1.0d+0, 0.0d+0 ) )
202 DOUBLE PRECISION RWORK( 50 )
203 COMPLEX*16 WORK( 26 ), Z( 8, 8 )
206 INTRINSIC cdabs, dble, dcmplx, dconjg, sqrt
220 a( i, i ) = dcmplx( i ) + alpha
230 a( 1, 1 ) = dcmplx( rone, rone )
231 a( 2, 2 ) = dconjg( a( 1, 1 ) )
233 a( 4, 4 ) = dcmplx( dble( one+alpha ), dble( one+beta ) )
234 a( 5, 5 ) = dconjg( a( 4, 4 ) )
239 CALL zlacpy(
'F', n, n, b, lda, y, ldy )
240 y( 3, 1 ) = -dconjg( wy )
241 y( 4, 1 ) = dconjg( wy )
242 y( 5, 1 ) = -dconjg( wy )
243 y( 3, 2 ) = -dconjg( wy )
244 y( 4, 2 ) = dconjg( wy )
245 y( 5, 2 ) = -dconjg( wy )
247 CALL zlacpy(
'F', n, n, b, lda, x, ldx )
263 a( 1, 3 ) = wx*a( 1, 1 ) + wy*a( 3, 3 )
264 a( 2, 3 ) = -wx*a( 2, 2 ) + wy*a( 3, 3 )
265 a( 1, 4 ) = wx*a( 1, 1 ) - wy*a( 4, 4 )
266 a( 2, 4 ) = wx*a( 2, 2 ) - wy*a( 4, 4 )
267 a( 1, 5 ) = -wx*a( 1, 1 ) + wy*a( 5, 5 )
268 a( 2, 5 ) = wx*a( 2, 2 ) + wy*a( 5, 5 )
272 s( 1 ) = rone / sqrt( ( rone+three*cdabs( wy )*cdabs( wy ) ) /
273 $ ( rone+cdabs( a( 1, 1 ) )*cdabs( a( 1, 1 ) ) ) )
274 s( 2 ) = rone / sqrt( ( rone+three*cdabs( wy )*cdabs( wy ) ) /
275 $ ( rone+cdabs( a( 2, 2 ) )*cdabs( a( 2, 2 ) ) ) )
276 s( 3 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
277 $ ( rone+cdabs( a( 3, 3 ) )*cdabs( a( 3, 3 ) ) ) )
278 s( 4 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
279 $ ( rone+cdabs( a( 4, 4 ) )*cdabs( a( 4, 4 ) ) ) )
280 s( 5 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
281 $ ( rone+cdabs( a( 5, 5 ) )*cdabs( a( 5, 5 ) ) ) )
283 CALL zlakf2( 1, 4, a, lda, a( 2, 2 ), b, b( 2, 2 ), z, 8 )
284 CALL zgesvd(
'N',
'N', 8, 8, z, 8, rwork, work, 1, work( 2 ), 1,
285 $ work( 3 ), 24, rwork( 9 ), info )
286 dif( 1 ) = rwork( 8 )
288 CALL zlakf2( 4, 1, a, lda, a( 5, 5 ), b, b( 5, 5 ), z, 8 )
289 CALL zgesvd(
'N',
'N', 8, 8, z, 8, rwork, work, 1, work( 2 ), 1,
290 $ work( 3 ), 24, rwork( 9 ), info )
291 dif( 5 ) = rwork( 8 )
subroutine zgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info)
ZGESVD computes the singular value decomposition (SVD) for GE matrices