267 SUBROUTINE zlatm5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
268 $ e,
lde, f, ldf, r, ldr, l, ldl, alpha, qblcka,
277 INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
278 $ prtype, qblcka, qblckb
279 DOUBLE PRECISION ALPHA
282 COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * ),
283 $ d( ldd, * ), e( lde, * ), f( ldf, * ),
284 $ l( ldl, * ), r( ldr, * )
290 COMPLEX*16 ONE, TWO, ZERO, HALF, TWENTY
291 parameter ( one = ( 1.0d+0, 0.0d+0 ),
292 $ two = ( 2.0d+0, 0.0d+0 ),
293 $ zero = ( 0.0d+0, 0.0d+0 ),
294 $ half = ( 0.5d+0, 0.0d+0 ),
295 $ twenty = ( 2.0d+1, 0.0d+0 ) )
299 COMPLEX*16 IMEPS, REEPS
302 INTRINSIC dcmplx, mod, sin
309 IF( prtype.EQ.1 )
THEN
315 ELSE IF( i.EQ.j-1 )
THEN
328 b( i, j ) = one - alpha
330 ELSE IF( i.EQ.j-1 )
THEN
342 r( i, j ) = ( half-sin( dcmplx( i / j ) ) )*twenty
343 l( i, j ) = r( i, j )
347 ELSE IF( prtype.EQ.2 .OR. prtype.EQ.3 )
THEN
351 a( i, j ) = ( half-sin( dcmplx( i ) ) )*two
352 d( i, j ) = ( half-sin( dcmplx( i*j ) ) )*two
363 b( i, j ) = ( half-sin( dcmplx( i+j ) ) )*two
364 e( i, j ) = ( half-sin( dcmplx( j ) ) )*two
374 r( i, j ) = ( half-sin( dcmplx( i*j ) ) )*twenty
375 l( i, j ) = ( half-sin( dcmplx( i+j ) ) )*twenty
379 IF( prtype.EQ.3 )
THEN
382 DO 130 k = 1, m - 1, qblcka
383 a( k+1, k+1 ) = a( k, k )
384 a( k+1, k ) = -sin( a( k, k+1 ) )
389 DO 140 k = 1, n - 1, qblckb
390 b( k+1, k+1 ) = b( k, k )
391 b( k+1, k ) = -sin( b( k, k+1 ) )
395 ELSE IF( prtype.EQ.4 )
THEN
398 a( i, j ) = ( half-sin( dcmplx( i*j ) ) )*twenty
399 d( i, j ) = ( half-sin( dcmplx( i+j ) ) )*two
405 b( i, j ) = ( half-sin( dcmplx( i+j ) ) )*twenty
406 e( i, j ) = ( half-sin( dcmplx( i*j ) ) )*two
412 r( i, j ) = ( half-sin( dcmplx( j / i ) ) )*twenty
413 l( i, j ) = ( half-sin( dcmplx( i*j ) ) )*two
417 ELSE IF( prtype.GE.5 )
THEN
418 reeps = half*two*twenty / alpha
419 imeps = ( half-two ) / alpha
422 r( i, j ) = ( half-sin( dcmplx( i*j ) ) )*alpha / twenty
423 l( i, j ) = ( half-sin( dcmplx( i+j ) ) )*alpha / twenty
435 $ a( i, i ) = one + reeps
436 IF( mod( i, 2 ).NE.0 .AND. i.LT.m )
THEN
438 ELSE IF( i.GT.1 )
THEN
441 ELSE IF( i.LE.8 )
THEN
447 IF( mod( i, 2 ).NE.0 .AND. i.LT.m )
THEN
449 ELSE IF( i.GT.1 )
THEN
454 IF( mod( i, 2 ).NE.0 .AND. i.LT.m )
THEN
455 a( i, i+1 ) = imeps*2
456 ELSE IF( i.GT.1 )
THEN
457 a( i, i-1 ) = -imeps*2
467 $ b( i, i ) = one - reeps
468 IF( mod( i, 2 ).NE.0 .AND. i.LT.n )
THEN
470 ELSE IF( i.GT.1 )
THEN
473 ELSE IF( i.LE.8 )
THEN
479 IF( mod( i, 2 ).NE.0 .AND. i.LT.n )
THEN
480 b( i, i+1 ) = one + imeps
481 ELSE IF( i.GT.1 )
THEN
482 b( i, i-1 ) = -one - imeps
485 b( i, i ) = one - reeps
486 IF( mod( i, 2 ).NE.0 .AND. i.LT.n )
THEN
487 b( i, i+1 ) = imeps*2
488 ELSE IF( i.GT.1 )
THEN
489 b( i, i-1 ) = -imeps*2
497 CALL zgemm(
'N',
'N', m, n, m, one, a, lda, r, ldr, zero, c, ldc )
498 CALL zgemm(
'N',
'N', m, n, n, -one, l, ldl, b, ldb, one, c, ldc )
499 CALL zgemm(
'N',
'N', m, n, m, one, d, ldd, r, ldr, zero, f, ldf )
500 CALL zgemm(
'N',
'N', m, n, n, -one, l, ldl, e, lde, one, f, ldf )
subroutine zlatm5(PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, QBLCKB)
ZLATM5
logical function lde(RI, RJ, LR)
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM