277 SUBROUTINE stfsm( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A,
286 CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO
291 REAL A( 0: * ), B( 0: ldb-1, 0: * )
299 parameter( one = 1.0e+0, zero = 0.0e+0 )
302 LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR,
304 INTEGER M1, M2, N1, N2, K, INFO, I, J
321 normaltransr = lsame( transr,
'N' )
322 lside = lsame( side,
'L' )
323 lower = lsame( uplo,
'L' )
324 notrans = lsame( trans,
'N' )
325 IF( .NOT.normaltransr .AND. .NOT.lsame( transr,
'T' ) )
THEN
327 ELSE IF( .NOT.lside .AND. .NOT.lsame( side,
'R' ) )
THEN
329 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo,
'U' ) )
THEN
331 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans,
'T' ) )
THEN
333 ELSE IF( .NOT.lsame( diag,
'N' ) .AND. .NOT.lsame( diag,
'U' ) )
336 ELSE IF( m.LT.0 )
THEN
338 ELSE IF( n.LT.0 )
THEN
340 ELSE IF( ldb.LT.max( 1, m ) )
THEN
344 CALL
xerbla(
'STFSM ', -info )
350 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
355 IF( alpha.EQ.zero )
THEN
372 IF( mod( m, 2 ).EQ.0 )
THEN
390 IF( normaltransr )
THEN
404 CALL
strsm(
'L',
'L',
'N', diag, m1, n, alpha,
407 CALL
strsm(
'L',
'L',
'N', diag, m1, n, alpha,
408 $ a( 0 ), m, b, ldb )
409 CALL
sgemm(
'N',
'N', m2, n, m1, -one, a( m1 ),
410 $ m, b, ldb, alpha, b( m1, 0 ), ldb )
411 CALL
strsm(
'L',
'U',
'T', diag, m2, n, one,
412 $ a( m ), m, b( m1, 0 ), ldb )
421 CALL
strsm(
'L',
'L',
'T', diag, m1, n, alpha,
422 $ a( 0 ), m, b, ldb )
424 CALL
strsm(
'L',
'U',
'N', diag, m2, n, alpha,
425 $ a( m ), m, b( m1, 0 ), ldb )
426 CALL
sgemm(
'T',
'N', m1, n, m2, -one, a( m1 ),
427 $ m, b( m1, 0 ), ldb, alpha, b, ldb )
428 CALL
strsm(
'L',
'L',
'T', diag, m1, n, one,
429 $ a( 0 ), m, b, ldb )
438 IF( .NOT.notrans )
THEN
443 CALL
strsm(
'L',
'L',
'N', diag, m1, n, alpha,
444 $ a( m2 ), m, b, ldb )
445 CALL
sgemm(
'T',
'N', m2, n, m1, -one, a( 0 ), m,
446 $ b, ldb, alpha, b( m1, 0 ), ldb )
447 CALL
strsm(
'L',
'U',
'T', diag, m2, n, one,
448 $ a( m1 ), m, b( m1, 0 ), ldb )
455 CALL
strsm(
'L',
'U',
'N', diag, m2, n, alpha,
456 $ a( m1 ), m, b( m1, 0 ), ldb )
457 CALL
sgemm(
'N',
'N', m1, n, m2, -one, a( 0 ), m,
458 $ b( m1, 0 ), ldb, alpha, b, ldb )
459 CALL
strsm(
'L',
'L',
'T', diag, m1, n, one,
460 $ a( m2 ), m, b, ldb )
480 CALL
strsm(
'L',
'U',
'T', diag, m1, n, alpha,
481 $ a( 0 ), m1, b, ldb )
483 CALL
strsm(
'L',
'U',
'T', diag, m1, n, alpha,
484 $ a( 0 ), m1, b, ldb )
485 CALL
sgemm(
'T',
'N', m2, n, m1, -one,
486 $ a( m1*m1 ), m1, b, ldb, alpha,
488 CALL
strsm(
'L',
'L',
'N', diag, m2, n, one,
489 $ a( 1 ), m1, b( m1, 0 ), ldb )
498 CALL
strsm(
'L',
'U',
'N', diag, m1, n, alpha,
499 $ a( 0 ), m1, b, ldb )
501 CALL
strsm(
'L',
'L',
'T', diag, m2, n, alpha,
502 $ a( 1 ), m1, b( m1, 0 ), ldb )
503 CALL
sgemm(
'N',
'N', m1, n, m2, -one,
504 $ a( m1*m1 ), m1, b( m1, 0 ), ldb,
506 CALL
strsm(
'L',
'U',
'N', diag, m1, n, one,
507 $ a( 0 ), m1, b, ldb )
516 IF( .NOT.notrans )
THEN
521 CALL
strsm(
'L',
'U',
'T', diag, m1, n, alpha,
522 $ a( m2*m2 ), m2, b, ldb )
523 CALL
sgemm(
'N',
'N', m2, n, m1, -one, a( 0 ), m2,
524 $ b, ldb, alpha, b( m1, 0 ), ldb )
525 CALL
strsm(
'L',
'L',
'N', diag, m2, n, one,
526 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
533 CALL
strsm(
'L',
'L',
'T', diag, m2, n, alpha,
534 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
535 CALL
sgemm(
'T',
'N', m1, n, m2, -one, a( 0 ), m2,
536 $ b( m1, 0 ), ldb, alpha, b, ldb )
537 CALL
strsm(
'L',
'U',
'N', diag, m1, n, one,
538 $ a( m2*m2 ), m2, b, ldb )
550 IF( normaltransr )
THEN
563 CALL
strsm(
'L',
'L',
'N', diag, k, n, alpha,
564 $ a( 1 ), m+1, b, ldb )
565 CALL
sgemm(
'N',
'N', k, n, k, -one, a( k+1 ),
566 $ m+1, b, ldb, alpha, b( k, 0 ), ldb )
567 CALL
strsm(
'L',
'U',
'T', diag, k, n, one,
568 $ a( 0 ), m+1, b( k, 0 ), ldb )
575 CALL
strsm(
'L',
'U',
'N', diag, k, n, alpha,
576 $ a( 0 ), m+1, b( k, 0 ), ldb )
577 CALL
sgemm(
'T',
'N', k, n, k, -one, a( k+1 ),
578 $ m+1, b( k, 0 ), ldb, alpha, b, ldb )
579 CALL
strsm(
'L',
'L',
'T', diag, k, n, one,
580 $ a( 1 ), m+1, b, ldb )
588 IF( .NOT.notrans )
THEN
593 CALL
strsm(
'L',
'L',
'N', diag, k, n, alpha,
594 $ a( k+1 ), m+1, b, ldb )
595 CALL
sgemm(
'T',
'N', k, n, k, -one, a( 0 ), m+1,
596 $ b, ldb, alpha, b( k, 0 ), ldb )
597 CALL
strsm(
'L',
'U',
'T', diag, k, n, one,
598 $ a( k ), m+1, b( k, 0 ), ldb )
604 CALL
strsm(
'L',
'U',
'N', diag, k, n, alpha,
605 $ a( k ), m+1, b( k, 0 ), ldb )
606 CALL
sgemm(
'N',
'N', k, n, k, -one, a( 0 ), m+1,
607 $ b( k, 0 ), ldb, alpha, b, ldb )
608 CALL
strsm(
'L',
'L',
'T', diag, k, n, one,
609 $ a( k+1 ), m+1, b, ldb )
628 CALL
strsm(
'L',
'U',
'T', diag, k, n, alpha,
629 $ a( k ), k, b, ldb )
630 CALL
sgemm(
'T',
'N', k, n, k, -one,
631 $ a( k*( k+1 ) ), k, b, ldb, alpha,
633 CALL
strsm(
'L',
'L',
'N', diag, k, n, one,
634 $ a( 0 ), k, b( k, 0 ), ldb )
641 CALL
strsm(
'L',
'L',
'T', diag, k, n, alpha,
642 $ a( 0 ), k, b( k, 0 ), ldb )
643 CALL
sgemm(
'N',
'N', k, n, k, -one,
644 $ a( k*( k+1 ) ), k, b( k, 0 ), ldb,
646 CALL
strsm(
'L',
'U',
'N', diag, k, n, one,
647 $ a( k ), k, b, ldb )
655 IF( .NOT.notrans )
THEN
660 CALL
strsm(
'L',
'U',
'T', diag, k, n, alpha,
661 $ a( k*( k+1 ) ), k, b, ldb )
662 CALL
sgemm(
'N',
'N', k, n, k, -one, a( 0 ), k, b,
663 $ ldb, alpha, b( k, 0 ), ldb )
664 CALL
strsm(
'L',
'L',
'N', diag, k, n, one,
665 $ a( k*k ), k, b( k, 0 ), ldb )
672 CALL
strsm(
'L',
'L',
'T', diag, k, n, alpha,
673 $ a( k*k ), k, b( k, 0 ), ldb )
674 CALL
sgemm(
'T',
'N', k, n, k, -one, a( 0 ), k,
675 $ b( k, 0 ), ldb, alpha, b, ldb )
676 CALL
strsm(
'L',
'U',
'N', diag, k, n, one,
677 $ a( k*( k+1 ) ), k, b, ldb )
695 IF( mod( n, 2 ).EQ.0 )
THEN
713 IF( normaltransr )
THEN
726 CALL
strsm(
'R',
'U',
'T', diag, m, n2, alpha,
727 $ a( n ), n, b( 0, n1 ), ldb )
728 CALL
sgemm(
'N',
'N', m, n1, n2, -one, b( 0, n1 ),
729 $ ldb, a( n1 ), n, alpha, b( 0, 0 ),
731 CALL
strsm(
'R',
'L',
'N', diag, m, n1, one,
732 $ a( 0 ), n, b( 0, 0 ), ldb )
739 CALL
strsm(
'R',
'L',
'T', diag, m, n1, alpha,
740 $ a( 0 ), n, b( 0, 0 ), ldb )
741 CALL
sgemm(
'N',
'T', m, n2, n1, -one, b( 0, 0 ),
742 $ ldb, a( n1 ), n, alpha, b( 0, n1 ),
744 CALL
strsm(
'R',
'U',
'N', diag, m, n2, one,
745 $ a( n ), n, b( 0, n1 ), ldb )
758 CALL
strsm(
'R',
'L',
'T', diag, m, n1, alpha,
759 $ a( n2 ), n, b( 0, 0 ), ldb )
760 CALL
sgemm(
'N',
'N', m, n2, n1, -one, b( 0, 0 ),
761 $ ldb, a( 0 ), n, alpha, b( 0, n1 ),
763 CALL
strsm(
'R',
'U',
'N', diag, m, n2, one,
764 $ a( n1 ), n, b( 0, n1 ), ldb )
771 CALL
strsm(
'R',
'U',
'T', diag, m, n2, alpha,
772 $ a( n1 ), n, b( 0, n1 ), ldb )
773 CALL
sgemm(
'N',
'T', m, n1, n2, -one, b( 0, n1 ),
774 $ ldb, a( 0 ), n, alpha, b( 0, 0 ), ldb )
775 CALL
strsm(
'R',
'L',
'N', diag, m, n1, one,
776 $ a( n2 ), n, b( 0, 0 ), ldb )
795 CALL
strsm(
'R',
'L',
'N', diag, m, n2, alpha,
796 $ a( 1 ), n1, b( 0, n1 ), ldb )
797 CALL
sgemm(
'N',
'T', m, n1, n2, -one, b( 0, n1 ),
798 $ ldb, a( n1*n1 ), n1, alpha, b( 0, 0 ),
800 CALL
strsm(
'R',
'U',
'T', diag, m, n1, one,
801 $ a( 0 ), n1, b( 0, 0 ), ldb )
808 CALL
strsm(
'R',
'U',
'N', diag, m, n1, alpha,
809 $ a( 0 ), n1, b( 0, 0 ), ldb )
810 CALL
sgemm(
'N',
'N', m, n2, n1, -one, b( 0, 0 ),
811 $ ldb, a( n1*n1 ), n1, alpha, b( 0, n1 ),
813 CALL
strsm(
'R',
'L',
'T', diag, m, n2, one,
814 $ a( 1 ), n1, b( 0, n1 ), ldb )
827 CALL
strsm(
'R',
'U',
'N', diag, m, n1, alpha,
828 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
829 CALL
sgemm(
'N',
'T', m, n2, n1, -one, b( 0, 0 ),
830 $ ldb, a( 0 ), n2, alpha, b( 0, n1 ),
832 CALL
strsm(
'R',
'L',
'T', diag, m, n2, one,
833 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
840 CALL
strsm(
'R',
'L',
'N', diag, m, n2, alpha,
841 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
842 CALL
sgemm(
'N',
'N', m, n1, n2, -one, b( 0, n1 ),
843 $ ldb, a( 0 ), n2, alpha, b( 0, 0 ),
845 CALL
strsm(
'R',
'U',
'T', diag, m, n1, one,
846 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
858 IF( normaltransr )
THEN
871 CALL
strsm(
'R',
'U',
'T', diag, m, k, alpha,
872 $ a( 0 ), n+1, b( 0, k ), ldb )
873 CALL
sgemm(
'N',
'N', m, k, k, -one, b( 0, k ),
874 $ ldb, a( k+1 ), n+1, alpha, b( 0, 0 ),
876 CALL
strsm(
'R',
'L',
'N', diag, m, k, one,
877 $ a( 1 ), n+1, b( 0, 0 ), ldb )
884 CALL
strsm(
'R',
'L',
'T', diag, m, k, alpha,
885 $ a( 1 ), n+1, b( 0, 0 ), ldb )
886 CALL
sgemm(
'N',
'T', m, k, k, -one, b( 0, 0 ),
887 $ ldb, a( k+1 ), n+1, alpha, b( 0, k ),
889 CALL
strsm(
'R',
'U',
'N', diag, m, k, one,
890 $ a( 0 ), n+1, b( 0, k ), ldb )
903 CALL
strsm(
'R',
'L',
'T', diag, m, k, alpha,
904 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
905 CALL
sgemm(
'N',
'N', m, k, k, -one, b( 0, 0 ),
906 $ ldb, a( 0 ), n+1, alpha, b( 0, k ),
908 CALL
strsm(
'R',
'U',
'N', diag, m, k, one,
909 $ a( k ), n+1, b( 0, k ), ldb )
916 CALL
strsm(
'R',
'U',
'T', diag, m, k, alpha,
917 $ a( k ), n+1, b( 0, k ), ldb )
918 CALL
sgemm(
'N',
'T', m, k, k, -one, b( 0, k ),
919 $ ldb, a( 0 ), n+1, alpha, b( 0, 0 ),
921 CALL
strsm(
'R',
'L',
'N', diag, m, k, one,
922 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
941 CALL
strsm(
'R',
'L',
'N', diag, m, k, alpha,
942 $ a( 0 ), k, b( 0, k ), ldb )
943 CALL
sgemm(
'N',
'T', m, k, k, -one, b( 0, k ),
944 $ ldb, a( ( k+1 )*k ), k, alpha,
946 CALL
strsm(
'R',
'U',
'T', diag, m, k, one,
947 $ a( k ), k, b( 0, 0 ), ldb )
954 CALL
strsm(
'R',
'U',
'N', diag, m, k, alpha,
955 $ a( k ), k, b( 0, 0 ), ldb )
956 CALL
sgemm(
'N',
'N', m, k, k, -one, b( 0, 0 ),
957 $ ldb, a( ( k+1 )*k ), k, alpha,
959 CALL
strsm(
'R',
'L',
'T', diag, m, k, one,
960 $ a( 0 ), k, b( 0, k ), ldb )
973 CALL
strsm(
'R',
'U',
'N', diag, m, k, alpha,
974 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
975 CALL
sgemm(
'N',
'T', m, k, k, -one, b( 0, 0 ),
976 $ ldb, a( 0 ), k, alpha, b( 0, k ), ldb )
977 CALL
strsm(
'R',
'L',
'T', diag, m, k, one,
978 $ a( k*k ), k, b( 0, k ), ldb )
985 CALL
strsm(
'R',
'L',
'N', diag, m, k, alpha,
986 $ a( k*k ), k, b( 0, k ), ldb )
987 CALL
sgemm(
'N',
'N', m, k, k, -one, b( 0, k ),
988 $ ldb, a( 0 ), k, alpha, b( 0, 0 ), ldb )
989 CALL
strsm(
'R',
'U',
'T', diag, m, k, one,
990 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
subroutine stfsm(TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB)
STFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM