251 SUBROUTINE ctprfb( 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 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
ctrmm(
'L',
'U',
'C',
'N', l, n, one, v( mp, 1 ), ldv,
356 CALL
cgemm(
'C',
'N', l, n, m-l, one, v, ldv, b, ldb,
357 $ one, work, ldwork )
358 CALL
cgemm(
'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
ctrmm(
'L',
'U', trans,
'N', k, n, one, t, ldt,
372 a( i, j ) = a( i, j ) - work( i, j )
376 CALL
cgemm(
'N',
'N', m-l, n, k, -one, v, ldv, work, ldwork,
378 CALL
cgemm(
'N',
'N', l, n, k-l, -one, v( mp, kp ), ldv,
379 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
380 CALL
ctrmm(
'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
ctrmm(
'R',
'U',
'N',
'N', m, l, one, v( np, 1 ), ldv,
416 CALL
cgemm(
'N',
'N', m, l, n-l, one, b, ldb,
417 $ v, ldv, one, work, ldwork )
418 CALL
cgemm(
'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
ctrmm(
'R',
'U', trans,
'N', m, k, one, t, ldt,
432 a( i, j ) = a( i, j ) - work( i, j )
436 CALL
cgemm(
'N',
'C', m, n-l, k, -one, work, ldwork,
437 $ v, ldv, one, b, ldb )
438 CALL
cgemm(
'N',
'C', m, l, k-l, -one, work( 1, kp ), ldwork,
439 $ v( np, kp ), ldv, one, b( 1, np ), ldb )
440 CALL
ctrmm(
'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
ctrmm(
'L',
'L',
'C',
'N', l, n, one, v( 1, kp ), ldv,
477 $ work( kp, 1 ), ldwork )
478 CALL
cgemm(
'C',
'N', l, n, m-l, one, v( mp, kp ), ldv,
479 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
480 CALL
cgemm(
'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
ctrmm(
'L',
'L', trans,
'N', k, n, one, t, ldt,
494 a( i, j ) = a( i, j ) - work( i, j )
498 CALL
cgemm(
'N',
'N', m-l, n, k, -one, v( mp, 1 ), ldv,
499 $ work, ldwork, one, b( mp, 1 ), ldb )
500 CALL
cgemm(
'N',
'N', l, n, k-l, -one, v, ldv,
501 $ work, ldwork, one, b, ldb )
502 CALL
ctrmm(
'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
ctrmm(
'R',
'L',
'N',
'N', m, l, one, v( 1, kp ), ldv,
537 $ work( 1, kp ), ldwork )
538 CALL
cgemm(
'N',
'N', m, l, n-l, one, b( 1, np ), ldb,
539 $ v( np, kp ), ldv, one, work( 1, kp ), ldwork )
540 CALL
cgemm(
'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
ctrmm(
'R',
'L', trans,
'N', m, k, one, t, ldt,
554 a( i, j ) = a( i, j ) - work( i, j )
558 CALL
cgemm(
'N',
'C', m, n-l, k, -one, work, ldwork,
559 $ v( np, 1 ), ldv, one, b( 1, np ), ldb )
560 CALL
cgemm(
'N',
'C', m, l, k-l, -one, work, ldwork,
561 $ v, ldv, one, b, ldb )
562 CALL
ctrmm(
'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
ctrmm(
'L',
'L',
'N',
'N', l, n, one, v( 1, mp ), ldv,
598 CALL
cgemm(
'N',
'N', l, n, m-l, one, v, ldv,b, ldb,
599 $ one, work, ldwork )
600 CALL
cgemm(
'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
ctrmm(
'L',
'U', trans,
'N', k, n, one, t, ldt,
614 a( i, j ) = a( i, j ) - work( i, j )
618 CALL
cgemm(
'C',
'N', m-l, n, k, -one, v, ldv, work, ldwork,
620 CALL
cgemm(
'C',
'N', l, n, k-l, -one, v( kp, mp ), ldv,
621 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
622 CALL
ctrmm(
'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
ctrmm(
'R',
'L',
'C',
'N', m, l, one, v( 1, np ), ldv,
657 CALL
cgemm(
'N',
'C', m, l, n-l, one, b, ldb, v, ldv,
658 $ one, work, ldwork )
659 CALL
cgemm(
'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
ctrmm(
'R',
'U', trans,
'N', m, k, one, t, ldt,
673 a( i, j ) = a( i, j ) - work( i, j )
677 CALL
cgemm(
'N',
'N', m, n-l, k, -one, work, ldwork,
678 $ v, ldv, one, b, ldb )
679 CALL
cgemm(
'N',
'N', m, l, k-l, -one, work( 1, kp ), ldwork,
680 $ v( kp, np ), ldv, one, b( 1, np ), ldb )
681 CALL
ctrmm(
'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
ctrmm(
'L',
'U',
'N',
'N', l, n, one, v( kp, 1 ), ldv,
716 $ work( kp, 1 ), ldwork )
717 CALL
cgemm(
'N',
'N', l, n, m-l, one, v( kp, mp ), ldv,
718 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
719 CALL
cgemm(
'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
ctrmm(
'L',
'L ', trans,
'N', k, n, one, t, ldt,
733 a( i, j ) = a( i, j ) - work( i, j )
737 CALL
cgemm(
'C',
'N', m-l, n, k, -one, v( 1, mp ), ldv,
738 $ work, ldwork, one, b( mp, 1 ), ldb )
739 CALL
cgemm(
'C',
'N', l, n, k-l, -one, v, ldv,
740 $ work, ldwork, one, b, ldb )
741 CALL
ctrmm(
'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
ctrmm(
'R',
'U',
'C',
'N', m, l, one, v( kp, 1 ), ldv,
775 $ work( 1, kp ), ldwork )
776 CALL
cgemm(
'N',
'C', m, l, n-l, one, b( 1, np ), ldb,
777 $ v( kp, np ), ldv, one, work( 1, kp ), ldwork )
778 CALL
cgemm(
'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
ctrmm(
'R',
'L', trans,
'N', m, k, one, t, ldt,
792 a( i, j ) = a( i, j ) - work( i, j )
796 CALL
cgemm(
'N',
'N', m, n-l, k, -one, work, ldwork,
797 $ v( 1, np ), ldv, one, b( 1, np ), ldb )
798 CALL
cgemm(
'N',
'N', m, l, k-l , -one, work, ldwork,
799 $ v, ldv, one, b, ldb )
800 CALL
ctrmm(
'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 ctrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRMM
subroutine ctprfb(SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK)
CTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matri...
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM