176 SUBROUTINE slatm6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
177 $ beta, wx, wy, s, dif )
185 INTEGER LDA, LDX, LDY, N, TYPE
186 REAL ALPHA, BETA, WX, WY
189 REAL A( lda, * ), B( lda, * ), DIF( * ), S( * ),
190 $ x( ldx, * ), y( ldy, * )
196 REAL ZERO, ONE, TWO, THREE
197 parameter ( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
204 REAL WORK( 100 ), Z( 12, 12 )
221 a( i, i ) =
REAL( I ) + ALPHA
233 CALL slacpy(
'F', n, n, b, lda, y, ldy )
241 CALL slacpy(
'F', n, n, b, lda, x, ldx )
258 a( 1, 3 ) = wx*a( 1, 1 ) + wy*a( 3, 3 )
259 a( 2, 3 ) = -wx*a( 2, 2 ) + wy*a( 3, 3 )
260 a( 1, 4 ) = wx*a( 1, 1 ) - wy*a( 4, 4 )
261 a( 2, 4 ) = wx*a( 2, 2 ) - wy*a( 4, 4 )
262 a( 1, 5 ) = -wx*a( 1, 1 ) + wy*a( 5, 5 )
263 a( 2, 5 ) = wx*a( 2, 2 ) + wy*a( 5, 5 )
264 ELSE IF( type.EQ.2 )
THEN
265 a( 1, 3 ) = two*wx + wy
267 a( 1, 4 ) = -wy*( two+alpha+beta )
268 a( 2, 4 ) = two*wx - wy*( two+alpha+beta )
269 a( 1, 5 ) = -two*wx + wy*( alpha-beta )
270 a( 2, 5 ) = wy*( alpha-beta )
274 a( 2, 2 ) = a( 1, 1 )
276 a( 4, 4 ) = one + alpha
277 a( 4, 5 ) = one + beta
278 a( 5, 4 ) = -a( 4, 5 )
279 a( 5, 5 ) = a( 4, 4 )
286 s( 1 ) = one / sqrt( ( one+three*wy*wy ) /
287 $ ( one+a( 1, 1 )*a( 1, 1 ) ) )
288 s( 2 ) = one / sqrt( ( one+three*wy*wy ) /
289 $ ( one+a( 2, 2 )*a( 2, 2 ) ) )
290 s( 3 ) = one / sqrt( ( one+two*wx*wx ) /
291 $ ( one+a( 3, 3 )*a( 3, 3 ) ) )
292 s( 4 ) = one / sqrt( ( one+two*wx*wx ) /
293 $ ( one+a( 4, 4 )*a( 4, 4 ) ) )
294 s( 5 ) = one / sqrt( ( one+two*wx*wx ) /
295 $ ( one+a( 5, 5 )*a( 5, 5 ) ) )
297 CALL slakf2( 1, 4, a, lda, a( 2, 2 ), b, b( 2, 2 ), z, 12 )
298 CALL sgesvd(
'N',
'N', 8, 8, z, 12, work, work( 9 ), 1,
299 $ work( 10 ), 1, work( 11 ), 40, info )
302 CALL slakf2( 4, 1, a, lda, a( 5, 5 ), b, b( 5, 5 ), z, 12 )
303 CALL sgesvd(
'N',
'N', 8, 8, z, 12, work, work( 9 ), 1,
304 $ work( 10 ), 1, work( 11 ), 40, info )
307 ELSE IF( type.EQ.2 )
THEN
309 s( 1 ) = one / sqrt( one / three+wy*wy )
311 s( 3 ) = one / sqrt( one / two+wx*wx )
312 s( 4 ) = one / sqrt( ( one+two*wx*wx ) /
313 $ ( one+( one+alpha )*( one+alpha )+( one+beta )*( one+
317 CALL slakf2( 2, 3, a, lda, a( 3, 3 ), b, b( 3, 3 ), z, 12 )
318 CALL sgesvd(
'N',
'N', 12, 12, z, 12, work, work( 13 ), 1,
319 $ work( 14 ), 1, work( 15 ), 60, info )
320 dif( 1 ) = work( 12 )
322 CALL slakf2( 3, 2, a, lda, a( 4, 4 ), b, b( 4, 4 ), z, 12 )
323 CALL sgesvd(
'N',
'N', 12, 12, z, 12, work, work( 13 ), 1,
324 $ work( 14 ), 1, work( 15 ), 60, info )
325 dif( 5 ) = work( 12 )
subroutine slatm6(TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, BETA, WX, WY, S, DIF)
SLATM6
subroutine slakf2(M, N, A, LDA, B, D, E, Z, LDZ)
SLAKF2
subroutine sgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO)
SGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.