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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zlakf2(M, N, A, LDA, B, D, E, Z, LDZ)
ZLAKF2
subroutine zlatm6(TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, BETA, WX, WY, S, DIF)
ZLATM6
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j