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