174 SUBROUTINE zlatm6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
175 $ beta, wx, wy, s, dif )
183 INTEGER LDA, LDX, LDY, N, TYPE
184 COMPLEX*16 ALPHA, BETA, WX, WY
187 DOUBLE PRECISION DIF( * ), S( * )
188 COMPLEX*16 A( lda, * ), B( lda, * ), X( ldx, * ),
195 DOUBLE PRECISION RONE, TWO, THREE
196 parameter ( rone = 1.0d+0, two = 2.0d+0, three = 3.0d+0 )
198 parameter ( zero = ( 0.0d+0, 0.0d+0 ),
199 $ one = ( 1.0d+0, 0.0d+0 ) )
205 DOUBLE PRECISION RWORK( 50 )
206 COMPLEX*16 WORK( 26 ), Z( 8, 8 )
209 INTRINSIC cdabs, dble, dcmplx, dconjg, sqrt
223 a( i, i ) = dcmplx( i ) + alpha
233 a( 1, 1 ) = dcmplx( rone, rone )
234 a( 2, 2 ) = dconjg( a( 1, 1 ) )
236 a( 4, 4 ) = dcmplx( dble( one+alpha ), dble( one+beta ) )
237 a( 5, 5 ) = dconjg( a( 4, 4 ) )
242 CALL zlacpy(
'F', n, n, b, lda, y, ldy )
243 y( 3, 1 ) = -dconjg( wy )
244 y( 4, 1 ) = dconjg( wy )
245 y( 5, 1 ) = -dconjg( wy )
246 y( 3, 2 ) = -dconjg( wy )
247 y( 4, 2 ) = dconjg( wy )
248 y( 5, 2 ) = -dconjg( wy )
250 CALL zlacpy(
'F', n, n, b, lda, x, ldx )
266 a( 1, 3 ) = wx*a( 1, 1 ) + wy*a( 3, 3 )
267 a( 2, 3 ) = -wx*a( 2, 2 ) + wy*a( 3, 3 )
268 a( 1, 4 ) = wx*a( 1, 1 ) - wy*a( 4, 4 )
269 a( 2, 4 ) = wx*a( 2, 2 ) - wy*a( 4, 4 )
270 a( 1, 5 ) = -wx*a( 1, 1 ) + wy*a( 5, 5 )
271 a( 2, 5 ) = wx*a( 2, 2 ) + wy*a( 5, 5 )
275 s( 1 ) = rone / sqrt( ( rone+three*cdabs( wy )*cdabs( wy ) ) /
276 $ ( rone+cdabs( a( 1, 1 ) )*cdabs( a( 1, 1 ) ) ) )
277 s( 2 ) = rone / sqrt( ( rone+three*cdabs( wy )*cdabs( wy ) ) /
278 $ ( rone+cdabs( a( 2, 2 ) )*cdabs( a( 2, 2 ) ) ) )
279 s( 3 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
280 $ ( rone+cdabs( a( 3, 3 ) )*cdabs( a( 3, 3 ) ) ) )
281 s( 4 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
282 $ ( rone+cdabs( a( 4, 4 ) )*cdabs( a( 4, 4 ) ) ) )
283 s( 5 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
284 $ ( rone+cdabs( a( 5, 5 ) )*cdabs( a( 5, 5 ) ) ) )
286 CALL zlakf2( 1, 4, a, lda, a( 2, 2 ), b, b( 2, 2 ), z, 8 )
287 CALL zgesvd(
'N',
'N', 8, 8, z, 8, rwork, work, 1, work( 2 ), 1,
288 $ work( 3 ), 24, rwork( 9 ), info )
289 dif( 1 ) = rwork( 8 )
291 CALL zlakf2( 4, 1, a, lda, a( 5, 5 ), b, b( 5, 5 ), z, 8 )
292 CALL zgesvd(
'N',
'N', 8, 8, z, 8, rwork, work, 1, work( 2 ), 1,
293 $ work( 3 ), 24, rwork( 9 ), info )
294 dif( 5 ) = rwork( 8 )
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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
subroutine zlatm6(TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, BETA, WX, WY, S, DIF)
ZLATM6
subroutine zlakf2(M, N, A, LDA, B, D, E, Z, LDZ)
ZLAKF2