298 SUBROUTINE ztfsm( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A,
307 CHARACTER transr, diag, side, trans, uplo
312 COMPLEX*16 a( 0: * ),
b( 0: ldb-1, 0: * )
318 COMPLEX*16 cone, czero
319 parameter( cone = ( 1.0d+0, 0.0d+0 ),
320 $ czero = ( 0.0d+0, 0.0d+0 ) )
323 LOGICAL lower, lside, misodd, nisodd, normaltransr,
325 INTEGER m1, m2, n1, n2, k, info, i,
j
342 normaltransr =
lsame( transr,
'N' )
343 lside =
lsame( side,
'L' )
344 lower =
lsame( uplo,
'L' )
345 notrans =
lsame( trans,
'N' )
346 IF( .NOT.normaltransr .AND. .NOT.
lsame( transr,
'C' ) )
THEN
348 ELSE IF( .NOT.lside .AND. .NOT.
lsame( side,
'R' ) )
THEN
350 ELSE IF( .NOT.lower .AND. .NOT.
lsame( uplo,
'U' ) )
THEN
352 ELSE IF( .NOT.notrans .AND. .NOT.
lsame( trans,
'C' ) )
THEN
354 ELSE IF( .NOT.
lsame( diag,
'N' ) .AND. .NOT.
lsame( diag,
'U' ) )
357 ELSE IF( m.LT.0 )
THEN
359 ELSE IF( n.LT.0 )
THEN
361 ELSE IF( ldb.LT.max( 1, m ) )
THEN
365 CALL
xerbla(
'ZTFSM ', -info )
371 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
376 IF( alpha.EQ.czero )
THEN
393 IF( mod( m, 2 ).EQ.0 )
THEN
411 IF( normaltransr )
THEN
425 CALL
ztrsm(
'L',
'L',
'N', diag, m1, n, alpha,
428 CALL
ztrsm(
'L',
'L',
'N', diag, m1, n, alpha,
429 $ a( 0 ), m,
b, ldb )
430 CALL
zgemm(
'N',
'N', m2, n, m1, -cone, a( m1 ),
431 $ m,
b, ldb, alpha,
b( m1, 0 ), ldb )
432 CALL
ztrsm(
'L',
'U',
'C', diag, m2, n, cone,
433 $ a( m ), m,
b( m1, 0 ), ldb )
442 CALL
ztrsm(
'L',
'L',
'C', diag, m1, n, alpha,
443 $ a( 0 ), m,
b, ldb )
445 CALL
ztrsm(
'L',
'U',
'N', diag, m2, n, alpha,
446 $ a( m ), m,
b( m1, 0 ), ldb )
447 CALL
zgemm(
'C',
'N', m1, n, m2, -cone, a( m1 ),
448 $ m,
b( m1, 0 ), ldb, alpha,
b, ldb )
449 CALL
ztrsm(
'L',
'L',
'C', diag, m1, n, cone,
450 $ a( 0 ), m,
b, ldb )
459 IF( .NOT.notrans )
THEN
464 CALL
ztrsm(
'L',
'L',
'N', diag, m1, n, alpha,
465 $ a( m2 ), m,
b, ldb )
466 CALL
zgemm(
'C',
'N', m2, n, m1, -cone, a( 0 ), m,
467 $
b, ldb, alpha,
b( m1, 0 ), ldb )
468 CALL
ztrsm(
'L',
'U',
'C', diag, m2, n, cone,
469 $ a( m1 ), m,
b( m1, 0 ), ldb )
476 CALL
ztrsm(
'L',
'U',
'N', diag, m2, n, alpha,
477 $ a( m1 ), m,
b( m1, 0 ), ldb )
478 CALL
zgemm(
'N',
'N', m1, n, m2, -cone, a( 0 ), m,
479 $
b( m1, 0 ), ldb, alpha,
b, ldb )
480 CALL
ztrsm(
'L',
'L',
'C', diag, m1, n, cone,
481 $ a( m2 ), m,
b, ldb )
501 CALL
ztrsm(
'L',
'U',
'C', diag, m1, n, alpha,
502 $ a( 0 ), m1,
b, ldb )
504 CALL
ztrsm(
'L',
'U',
'C', diag, m1, n, alpha,
505 $ a( 0 ), m1,
b, ldb )
506 CALL
zgemm(
'C',
'N', m2, n, m1, -cone,
507 $ a( m1*m1 ), m1,
b, ldb, alpha,
509 CALL
ztrsm(
'L',
'L',
'N', diag, m2, n, cone,
510 $ a( 1 ), m1,
b( m1, 0 ), ldb )
519 CALL
ztrsm(
'L',
'U',
'N', diag, m1, n, alpha,
520 $ a( 0 ), m1,
b, ldb )
522 CALL
ztrsm(
'L',
'L',
'C', diag, m2, n, alpha,
523 $ a( 1 ), m1,
b( m1, 0 ), ldb )
524 CALL
zgemm(
'N',
'N', m1, n, m2, -cone,
525 $ a( m1*m1 ), m1,
b( m1, 0 ), ldb,
527 CALL
ztrsm(
'L',
'U',
'N', diag, m1, n, cone,
528 $ a( 0 ), m1,
b, ldb )
537 IF( .NOT.notrans )
THEN
542 CALL
ztrsm(
'L',
'U',
'C', diag, m1, n, alpha,
543 $ a( m2*m2 ), m2,
b, ldb )
544 CALL
zgemm(
'N',
'N', m2, n, m1, -cone, a( 0 ), m2,
545 $
b, ldb, alpha,
b( m1, 0 ), ldb )
546 CALL
ztrsm(
'L',
'L',
'N', diag, m2, n, cone,
547 $ a( m1*m2 ), m2,
b( m1, 0 ), ldb )
554 CALL
ztrsm(
'L',
'L',
'C', diag, m2, n, alpha,
555 $ a( m1*m2 ), m2,
b( m1, 0 ), ldb )
556 CALL
zgemm(
'C',
'N', m1, n, m2, -cone, a( 0 ), m2,
557 $
b( m1, 0 ), ldb, alpha,
b, ldb )
558 CALL
ztrsm(
'L',
'U',
'N', diag, m1, n, cone,
559 $ a( m2*m2 ), m2,
b, ldb )
571 IF( normaltransr )
THEN
584 CALL
ztrsm(
'L',
'L',
'N', diag, k, n, alpha,
585 $ a( 1 ), m+1,
b, ldb )
586 CALL
zgemm(
'N',
'N', k, n, k, -cone, a( k+1 ),
587 $ m+1,
b, ldb, alpha,
b( k, 0 ), ldb )
588 CALL
ztrsm(
'L',
'U',
'C', diag, k, n, cone,
589 $ a( 0 ), m+1,
b( k, 0 ), ldb )
596 CALL
ztrsm(
'L',
'U',
'N', diag, k, n, alpha,
597 $ a( 0 ), m+1,
b( k, 0 ), ldb )
598 CALL
zgemm(
'C',
'N', k, n, k, -cone, a( k+1 ),
599 $ m+1,
b( k, 0 ), ldb, alpha,
b, ldb )
600 CALL
ztrsm(
'L',
'L',
'C', diag, k, n, cone,
601 $ a( 1 ), m+1,
b, ldb )
609 IF( .NOT.notrans )
THEN
614 CALL
ztrsm(
'L',
'L',
'N', diag, k, n, alpha,
615 $ a( k+1 ), m+1,
b, ldb )
616 CALL
zgemm(
'C',
'N', k, n, k, -cone, a( 0 ), m+1,
617 $
b, ldb, alpha,
b( k, 0 ), ldb )
618 CALL
ztrsm(
'L',
'U',
'C', diag, k, n, cone,
619 $ a( k ), m+1,
b( k, 0 ), ldb )
625 CALL
ztrsm(
'L',
'U',
'N', diag, k, n, alpha,
626 $ a( k ), m+1,
b( k, 0 ), ldb )
627 CALL
zgemm(
'N',
'N', k, n, k, -cone, a( 0 ), m+1,
628 $
b( k, 0 ), ldb, alpha,
b, ldb )
629 CALL
ztrsm(
'L',
'L',
'C', diag, k, n, cone,
630 $ a( k+1 ), m+1,
b, ldb )
649 CALL
ztrsm(
'L',
'U',
'C', diag, k, n, alpha,
650 $ a( k ), k,
b, ldb )
651 CALL
zgemm(
'C',
'N', k, n, k, -cone,
652 $ a( k*( k+1 ) ), k,
b, ldb, alpha,
654 CALL
ztrsm(
'L',
'L',
'N', diag, k, n, cone,
655 $ a( 0 ), k,
b( k, 0 ), ldb )
662 CALL
ztrsm(
'L',
'L',
'C', diag, k, n, alpha,
663 $ a( 0 ), k,
b( k, 0 ), ldb )
664 CALL
zgemm(
'N',
'N', k, n, k, -cone,
665 $ a( k*( k+1 ) ), k,
b( k, 0 ), ldb,
667 CALL
ztrsm(
'L',
'U',
'N', diag, k, n, cone,
668 $ a( k ), k,
b, ldb )
676 IF( .NOT.notrans )
THEN
681 CALL
ztrsm(
'L',
'U',
'C', diag, k, n, alpha,
682 $ a( k*( k+1 ) ), k,
b, ldb )
683 CALL
zgemm(
'N',
'N', k, n, k, -cone, a( 0 ), k,
b,
684 $ ldb, alpha,
b( k, 0 ), ldb )
685 CALL
ztrsm(
'L',
'L',
'N', diag, k, n, cone,
686 $ a( k*k ), k,
b( k, 0 ), ldb )
693 CALL
ztrsm(
'L',
'L',
'C', diag, k, n, alpha,
694 $ a( k*k ), k,
b( k, 0 ), ldb )
695 CALL
zgemm(
'C',
'N', k, n, k, -cone, a( 0 ), k,
696 $
b( k, 0 ), ldb, alpha,
b, ldb )
697 CALL
ztrsm(
'L',
'U',
'N', diag, k, n, cone,
698 $ a( k*( k+1 ) ), k,
b, ldb )
716 IF( mod( n, 2 ).EQ.0 )
THEN
734 IF( normaltransr )
THEN
747 CALL
ztrsm(
'R',
'U',
'C', diag, m, n2, alpha,
748 $ a( n ), n,
b( 0, n1 ), ldb )
749 CALL
zgemm(
'N',
'N', m, n1, n2, -cone,
b( 0, n1 ),
750 $ ldb, a( n1 ), n, alpha,
b( 0, 0 ),
752 CALL
ztrsm(
'R',
'L',
'N', diag, m, n1, cone,
753 $ a( 0 ), n,
b( 0, 0 ), ldb )
760 CALL
ztrsm(
'R',
'L',
'C', diag, m, n1, alpha,
761 $ a( 0 ), n,
b( 0, 0 ), ldb )
762 CALL
zgemm(
'N',
'C', m, n2, n1, -cone,
b( 0, 0 ),
763 $ ldb, a( n1 ), n, alpha,
b( 0, n1 ),
765 CALL
ztrsm(
'R',
'U',
'N', diag, m, n2, cone,
766 $ a( n ), n,
b( 0, n1 ), ldb )
779 CALL
ztrsm(
'R',
'L',
'C', diag, m, n1, alpha,
780 $ a( n2 ), n,
b( 0, 0 ), ldb )
781 CALL
zgemm(
'N',
'N', m, n2, n1, -cone,
b( 0, 0 ),
782 $ ldb, a( 0 ), n, alpha,
b( 0, n1 ),
784 CALL
ztrsm(
'R',
'U',
'N', diag, m, n2, cone,
785 $ a( n1 ), n,
b( 0, n1 ), ldb )
792 CALL
ztrsm(
'R',
'U',
'C', diag, m, n2, alpha,
793 $ a( n1 ), n,
b( 0, n1 ), ldb )
794 CALL
zgemm(
'N',
'C', m, n1, n2, -cone,
b( 0, n1 ),
795 $ ldb, a( 0 ), n, alpha,
b( 0, 0 ), ldb )
796 CALL
ztrsm(
'R',
'L',
'N', diag, m, n1, cone,
797 $ a( n2 ), n,
b( 0, 0 ), ldb )
816 CALL
ztrsm(
'R',
'L',
'N', diag, m, n2, alpha,
817 $ a( 1 ), n1,
b( 0, n1 ), ldb )
818 CALL
zgemm(
'N',
'C', m, n1, n2, -cone,
b( 0, n1 ),
819 $ ldb, a( n1*n1 ), n1, alpha,
b( 0, 0 ),
821 CALL
ztrsm(
'R',
'U',
'C', diag, m, n1, cone,
822 $ a( 0 ), n1,
b( 0, 0 ), ldb )
829 CALL
ztrsm(
'R',
'U',
'N', diag, m, n1, alpha,
830 $ a( 0 ), n1,
b( 0, 0 ), ldb )
831 CALL
zgemm(
'N',
'N', m, n2, n1, -cone,
b( 0, 0 ),
832 $ ldb, a( n1*n1 ), n1, alpha,
b( 0, n1 ),
834 CALL
ztrsm(
'R',
'L',
'C', diag, m, n2, cone,
835 $ a( 1 ), n1,
b( 0, n1 ), ldb )
848 CALL
ztrsm(
'R',
'U',
'N', diag, m, n1, alpha,
849 $ a( n2*n2 ), n2,
b( 0, 0 ), ldb )
850 CALL
zgemm(
'N',
'C', m, n2, n1, -cone,
b( 0, 0 ),
851 $ ldb, a( 0 ), n2, alpha,
b( 0, n1 ),
853 CALL
ztrsm(
'R',
'L',
'C', diag, m, n2, cone,
854 $ a( n1*n2 ), n2,
b( 0, n1 ), ldb )
861 CALL
ztrsm(
'R',
'L',
'N', diag, m, n2, alpha,
862 $ a( n1*n2 ), n2,
b( 0, n1 ), ldb )
863 CALL
zgemm(
'N',
'N', m, n1, n2, -cone,
b( 0, n1 ),
864 $ ldb, a( 0 ), n2, alpha,
b( 0, 0 ),
866 CALL
ztrsm(
'R',
'U',
'C', diag, m, n1, cone,
867 $ a( n2*n2 ), n2,
b( 0, 0 ), ldb )
879 IF( normaltransr )
THEN
892 CALL
ztrsm(
'R',
'U',
'C', diag, m, k, alpha,
893 $ a( 0 ), n+1,
b( 0, k ), ldb )
894 CALL
zgemm(
'N',
'N', m, k, k, -cone,
b( 0, k ),
895 $ ldb, a( k+1 ), n+1, alpha,
b( 0, 0 ),
897 CALL
ztrsm(
'R',
'L',
'N', diag, m, k, cone,
898 $ a( 1 ), n+1,
b( 0, 0 ), ldb )
905 CALL
ztrsm(
'R',
'L',
'C', diag, m, k, alpha,
906 $ a( 1 ), n+1,
b( 0, 0 ), ldb )
907 CALL
zgemm(
'N',
'C', m, k, k, -cone,
b( 0, 0 ),
908 $ ldb, a( k+1 ), n+1, alpha,
b( 0, k ),
910 CALL
ztrsm(
'R',
'U',
'N', diag, m, k, cone,
911 $ a( 0 ), n+1,
b( 0, k ), ldb )
924 CALL
ztrsm(
'R',
'L',
'C', diag, m, k, alpha,
925 $ a( k+1 ), n+1,
b( 0, 0 ), ldb )
926 CALL
zgemm(
'N',
'N', m, k, k, -cone,
b( 0, 0 ),
927 $ ldb, a( 0 ), n+1, alpha,
b( 0, k ),
929 CALL
ztrsm(
'R',
'U',
'N', diag, m, k, cone,
930 $ a( k ), n+1,
b( 0, k ), ldb )
937 CALL
ztrsm(
'R',
'U',
'C', diag, m, k, alpha,
938 $ a( k ), n+1,
b( 0, k ), ldb )
939 CALL
zgemm(
'N',
'C', m, k, k, -cone,
b( 0, k ),
940 $ ldb, a( 0 ), n+1, alpha,
b( 0, 0 ),
942 CALL
ztrsm(
'R',
'L',
'N', diag, m, k, cone,
943 $ a( k+1 ), n+1,
b( 0, 0 ), ldb )
962 CALL
ztrsm(
'R',
'L',
'N', diag, m, k, alpha,
963 $ a( 0 ), k,
b( 0, k ), ldb )
964 CALL
zgemm(
'N',
'C', m, k, k, -cone,
b( 0, k ),
965 $ ldb, a( ( k+1 )*k ), k, alpha,
967 CALL
ztrsm(
'R',
'U',
'C', diag, m, k, cone,
968 $ a( k ), k,
b( 0, 0 ), ldb )
975 CALL
ztrsm(
'R',
'U',
'N', diag, m, k, alpha,
976 $ a( k ), k,
b( 0, 0 ), ldb )
977 CALL
zgemm(
'N',
'N', m, k, k, -cone,
b( 0, 0 ),
978 $ ldb, a( ( k+1 )*k ), k, alpha,
980 CALL
ztrsm(
'R',
'L',
'C', diag, m, k, cone,
981 $ a( 0 ), k,
b( 0, k ), ldb )
994 CALL
ztrsm(
'R',
'U',
'N', diag, m, k, alpha,
995 $ a( ( k+1 )*k ), k,
b( 0, 0 ), ldb )
996 CALL
zgemm(
'N',
'C', m, k, k, -cone,
b( 0, 0 ),
997 $ ldb, a( 0 ), k, alpha,
b( 0, k ), ldb )
998 CALL
ztrsm(
'R',
'L',
'C', diag, m, k, cone,
999 $ a( k*k ), k,
b( 0, k ), ldb )
1006 CALL
ztrsm(
'R',
'L',
'N', diag, m, k, alpha,
1007 $ a( k*k ), k,
b( 0, k ), ldb )
1008 CALL
zgemm(
'N',
'N', m, k, k, -cone,
b( 0, k ),
1009 $ ldb, a( 0 ), k, alpha,
b( 0, 0 ), ldb )
1010 CALL
ztrsm(
'R',
'U',
'C', diag, m, k, cone,
1011 $ a( ( k+1 )*k ), k,
b( 0, 0 ), ldb )
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ztfsm(TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB)
ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j