251 SUBROUTINE ztprfb( SIDE, TRANS, DIRECT, STOREV, M, N, K, L,
252 $ v, ldv, t, ldt, a, lda, b, ldb, work, ldwork )
260 CHARACTER DIRECT, SIDE, STOREV, TRANS
261 INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N
264 COMPLEX*16 A( lda, * ), B( ldb, * ), T( ldt, * ),
265 $ v( ldv, * ), work( ldwork, * )
272 parameter( one = (1.0,0.0), zero = (0.0,0.0) )
275 INTEGER I, J, MP, NP, KP
276 LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW
292 IF( m.LE.0 .OR. n.LE.0 .OR. k.LE.0 .OR. l.LT.0 )
RETURN
294 IF( lsame( storev,
'C' ) )
THEN
297 ELSE IF ( lsame( storev,
'R' ) )
THEN
305 IF( lsame( side,
'L' ) )
THEN
308 ELSE IF( lsame( side,
'R' ) )
THEN
316 IF( lsame( direct,
'F' ) )
THEN
319 ELSE IF( lsame( direct,
'B' ) )
THEN
329 IF( column .AND. forward .AND. left )
THEN
351 work( i, j ) = b( m-l+i, j )
354 CALL
ztrmm(
'L',
'U',
'C',
'N', l, n, one, v( mp, 1 ), ldv,
356 CALL
zgemm(
'C',
'N', l, n, m-l, one, v, ldv, b, ldb,
357 $ one, work, ldwork )
358 CALL
zgemm(
'C',
'N', k-l, n, m, one, v( 1, kp ), ldv,
359 $ b, ldb, zero, work( kp, 1 ), ldwork )
363 work( i, j ) = work( i, j ) + a( i, j )
367 CALL
ztrmm(
'L',
'U', trans,
'N', k, n, one, t, ldt,
372 a( i, j ) = a( i, j ) - work( i, j )
376 CALL
zgemm(
'N',
'N', m-l, n, k, -one, v, ldv, work, ldwork,
378 CALL
zgemm(
'N',
'N', l, n, k-l, -one, v( mp, kp ), ldv,
379 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
380 CALL
ztrmm(
'L',
'U',
'N',
'N', l, n, one, v( mp, 1 ), ldv,
384 b( m-l+i, j ) = b( m-l+i, j ) - work( i, j )
390 ELSE IF( column .AND. forward .AND. right )
THEN
411 work( i, j ) = b( i, n-l+j )
414 CALL
ztrmm(
'R',
'U',
'N',
'N', m, l, one, v( np, 1 ), ldv,
416 CALL
zgemm(
'N',
'N', m, l, n-l, one, b, ldb,
417 $ v, ldv, one, work, ldwork )
418 CALL
zgemm(
'N',
'N', m, k-l, n, one, b, ldb,
419 $ v( 1, kp ), ldv, zero, work( 1, kp ), ldwork )
423 work( i, j ) = work( i, j ) + a( i, j )
427 CALL
ztrmm(
'R',
'U', trans,
'N', m, k, one, t, ldt,
432 a( i, j ) = a( i, j ) - work( i, j )
436 CALL
zgemm(
'N',
'C', m, n-l, k, -one, work, ldwork,
437 $ v, ldv, one, b, ldb )
438 CALL
zgemm(
'N',
'C', m, l, k-l, -one, work( 1, kp ), ldwork,
439 $ v( np, kp ), ldv, one, b( 1, np ), ldb )
440 CALL
ztrmm(
'R',
'U',
'C',
'N', m, l, one, v( np, 1 ), ldv,
444 b( i, n-l+j ) = b( i, n-l+j ) - work( i, j )
450 ELSE IF( column .AND. backward .AND. left )
THEN
472 work( k-l+i, j ) = b( i, j )
476 CALL
ztrmm(
'L',
'L',
'C',
'N', l, n, one, v( 1, kp ), ldv,
477 $ work( kp, 1 ), ldwork )
478 CALL
zgemm(
'C',
'N', l, n, m-l, one, v( mp, kp ), ldv,
479 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
480 CALL
zgemm(
'C',
'N', k-l, n, m, one, v, ldv,
481 $ b, ldb, zero, work, ldwork )
485 work( i, j ) = work( i, j ) + a( i, j )
489 CALL
ztrmm(
'L',
'L', trans,
'N', k, n, one, t, ldt,
494 a( i, j ) = a( i, j ) - work( i, j )
498 CALL
zgemm(
'N',
'N', m-l, n, k, -one, v( mp, 1 ), ldv,
499 $ work, ldwork, one, b( mp, 1 ), ldb )
500 CALL
zgemm(
'N',
'N', l, n, k-l, -one, v, ldv,
501 $ work, ldwork, one, b, ldb )
502 CALL
ztrmm(
'L',
'L',
'N',
'N', l, n, one, v( 1, kp ), ldv,
503 $ work( kp, 1 ), ldwork )
506 b( i, j ) = b( i, j ) - work( k-l+i, j )
512 ELSE IF( column .AND. backward .AND. right )
THEN
533 work( i, k-l+j ) = b( i, j )
536 CALL
ztrmm(
'R',
'L',
'N',
'N', m, l, one, v( 1, kp ), ldv,
537 $ work( 1, kp ), ldwork )
538 CALL
zgemm(
'N',
'N', m, l, n-l, one, b( 1, np ), ldb,
539 $ v( np, kp ), ldv, one, work( 1, kp ), ldwork )
540 CALL
zgemm(
'N',
'N', m, k-l, n, one, b, ldb,
541 $ v, ldv, zero, work, ldwork )
545 work( i, j ) = work( i, j ) + a( i, j )
549 CALL
ztrmm(
'R',
'L', trans,
'N', m, k, one, t, ldt,
554 a( i, j ) = a( i, j ) - work( i, j )
558 CALL
zgemm(
'N',
'C', m, n-l, k, -one, work, ldwork,
559 $ v( np, 1 ), ldv, one, b( 1, np ), ldb )
560 CALL
zgemm(
'N',
'C', m, l, k-l, -one, work, ldwork,
561 $ v, ldv, one, b, ldb )
562 CALL
ztrmm(
'R',
'L',
'C',
'N', m, l, one, v( 1, kp ), ldv,
563 $ work( 1, kp ), ldwork )
566 b( i, j ) = b( i, j ) - work( i, k-l+j )
572 ELSE IF( row .AND. forward .AND. left )
THEN
593 work( i, j ) = b( m-l+i, j )
596 CALL
ztrmm(
'L',
'L',
'N',
'N', l, n, one, v( 1, mp ), ldv,
598 CALL
zgemm(
'N',
'N', l, n, m-l, one, v, ldv,b, ldb,
599 $ one, work, ldwork )
600 CALL
zgemm(
'N',
'N', k-l, n, m, one, v( kp, 1 ), ldv,
601 $ b, ldb, zero, work( kp, 1 ), ldwork )
605 work( i, j ) = work( i, j ) + a( i, j )
609 CALL
ztrmm(
'L',
'U', trans,
'N', k, n, one, t, ldt,
614 a( i, j ) = a( i, j ) - work( i, j )
618 CALL
zgemm(
'C',
'N', m-l, n, k, -one, v, ldv, work, ldwork,
620 CALL
zgemm(
'C',
'N', l, n, k-l, -one, v( kp, mp ), ldv,
621 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
622 CALL
ztrmm(
'L',
'L',
'C',
'N', l, n, one, v( 1, mp ), ldv,
626 b( m-l+i, j ) = b( m-l+i, j ) - work( i, j )
632 ELSE IF( row .AND. forward .AND. right )
THEN
652 work( i, j ) = b( i, n-l+j )
655 CALL
ztrmm(
'R',
'L',
'C',
'N', m, l, one, v( 1, np ), ldv,
657 CALL
zgemm(
'N',
'C', m, l, n-l, one, b, ldb, v, ldv,
658 $ one, work, ldwork )
659 CALL
zgemm(
'N',
'C', m, k-l, n, one, b, ldb,
660 $ v( kp, 1 ), ldv, zero, work( 1, kp ), ldwork )
664 work( i, j ) = work( i, j ) + a( i, j )
668 CALL
ztrmm(
'R',
'U', trans,
'N', m, k, one, t, ldt,
673 a( i, j ) = a( i, j ) - work( i, j )
677 CALL
zgemm(
'N',
'N', m, n-l, k, -one, work, ldwork,
678 $ v, ldv, one, b, ldb )
679 CALL
zgemm(
'N',
'N', m, l, k-l, -one, work( 1, kp ), ldwork,
680 $ v( kp, np ), ldv, one, b( 1, np ), ldb )
681 CALL
ztrmm(
'R',
'L',
'N',
'N', m, l, one, v( 1, np ), ldv,
685 b( i, n-l+j ) = b( i, n-l+j ) - work( i, j )
691 ELSE IF( row .AND. backward .AND. left )
THEN
712 work( k-l+i, j ) = b( i, j )
715 CALL
ztrmm(
'L',
'U',
'N',
'N', l, n, one, v( kp, 1 ), ldv,
716 $ work( kp, 1 ), ldwork )
717 CALL
zgemm(
'N',
'N', l, n, m-l, one, v( kp, mp ), ldv,
718 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
719 CALL
zgemm(
'N',
'N', k-l, n, m, one, v, ldv, b, ldb,
720 $ zero, work, ldwork )
724 work( i, j ) = work( i, j ) + a( i, j )
728 CALL
ztrmm(
'L',
'L ', trans,
'N', k, n, one, t, ldt,
733 a( i, j ) = a( i, j ) - work( i, j )
737 CALL
zgemm(
'C',
'N', m-l, n, k, -one, v( 1, mp ), ldv,
738 $ work, ldwork, one, b( mp, 1 ), ldb )
739 CALL
zgemm(
'C',
'N', l, n, k-l, -one, v, ldv,
740 $ work, ldwork, one, b, ldb )
741 CALL
ztrmm(
'L',
'U',
'C',
'N', l, n, one, v( kp, 1 ), ldv,
742 $ work( kp, 1 ), ldwork )
745 b( i, j ) = b( i, j ) - work( k-l+i, j )
751 ELSE IF( row .AND. backward .AND. right )
THEN
771 work( i, k-l+j ) = b( i, j )
774 CALL
ztrmm(
'R',
'U',
'C',
'N', m, l, one, v( kp, 1 ), ldv,
775 $ work( 1, kp ), ldwork )
776 CALL
zgemm(
'N',
'C', m, l, n-l, one, b( 1, np ), ldb,
777 $ v( kp, np ), ldv, one, work( 1, kp ), ldwork )
778 CALL
zgemm(
'N',
'C', m, k-l, n, one, b, ldb, v, ldv,
779 $ zero, work, ldwork )
783 work( i, j ) = work( i, j ) + a( i, j )
787 CALL
ztrmm(
'R',
'L', trans,
'N', m, k, one, t, ldt,
792 a( i, j ) = a( i, j ) - work( i, j )
796 CALL
zgemm(
'N',
'N', m, n-l, k, -one, work, ldwork,
797 $ v( 1, np ), ldv, one, b( 1, np ), ldb )
798 CALL
zgemm(
'N',
'N', m, l, k-l , -one, work, ldwork,
799 $ v, ldv, one, b, ldb )
800 CALL
ztrmm(
'R',
'U',
'N',
'N', m, l, one, v( kp, 1 ), ldv,
801 $ work( 1, kp ), ldwork )
804 b( i, j ) = b( i, j ) - work( i, k-l+j )
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine ztprfb(SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK)
ZTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matri...
subroutine ztrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRMM