LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ dtfsm()

subroutine dtfsm ( character  transr,
character  side,
character  uplo,
character  trans,
character  diag,
integer  m,
integer  n,
double precision  alpha,
double precision, dimension( 0: * )  a,
double precision, dimension( 0: ldb-1, 0: * )  b,
integer  ldb 
)

DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).

Download DTFSM + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 Level 3 BLAS like routine for A in RFP Format.

 DTFSM  solves the matrix equation

    op( A )*X = alpha*B  or  X*op( A ) = alpha*B

 where alpha is a scalar, X and B are m by n matrices, A is a unit, or
 non-unit,  upper or lower triangular matrix  and  op( A )  is one  of

    op( A ) = A   or   op( A ) = A**T.

 A is in Rectangular Full Packed (RFP) Format.

 The matrix X is overwritten on B.
Parameters
[in]TRANSR
          TRANSR is CHARACTER*1
          = 'N':  The Normal Form of RFP A is stored;
          = 'T':  The Transpose Form of RFP A is stored.
[in]SIDE
          SIDE is CHARACTER*1
           On entry, SIDE specifies whether op( A ) appears on the left
           or right of X as follows:

              SIDE = 'L' or 'l'   op( A )*X = alpha*B.

              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.

           Unchanged on exit.
[in]UPLO
          UPLO is CHARACTER*1
           On entry, UPLO specifies whether the RFP matrix A came from
           an upper or lower triangular matrix as follows:
           UPLO = 'U' or 'u' RFP A came from an upper triangular matrix
           UPLO = 'L' or 'l' RFP A came from a  lower triangular matrix

           Unchanged on exit.
[in]TRANS
          TRANS is CHARACTER*1
           On entry, TRANS  specifies the form of op( A ) to be used
           in the matrix multiplication as follows:

              TRANS  = 'N' or 'n'   op( A ) = A.

              TRANS  = 'T' or 't'   op( A ) = A'.

           Unchanged on exit.
[in]DIAG
          DIAG is CHARACTER*1
           On entry, DIAG specifies whether or not RFP A is unit
           triangular as follows:

              DIAG = 'U' or 'u'   A is assumed to be unit triangular.

              DIAG = 'N' or 'n'   A is not assumed to be unit
                                  triangular.

           Unchanged on exit.
[in]M
          M is INTEGER
           On entry, M specifies the number of rows of B. M must be at
           least zero.
           Unchanged on exit.
[in]N
          N is INTEGER
           On entry, N specifies the number of columns of B.  N must be
           at least zero.
           Unchanged on exit.
[in]ALPHA
          ALPHA is DOUBLE PRECISION
           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
           zero then  A is not referenced and  B need not be set before
           entry.
           Unchanged on exit.
[in]A
          A is DOUBLE PRECISION array, dimension (NT)
           NT = N*(N+1)/2. On entry, the matrix A in RFP Format.
           RFP Format is described by TRANSR, UPLO and N as follows:
           If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
           K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
           TRANSR = 'T' then RFP is the transpose of RFP A as
           defined when TRANSR = 'N'. The contents of RFP A are defined
           by UPLO as follows: If UPLO = 'U' the RFP A contains the NT
           elements of upper packed A either in normal or
           transpose Format. If UPLO = 'L' the RFP A contains
           the NT elements of lower packed A either in normal or
           transpose Format. The LDA of RFP A is (N+1)/2 when
           TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is
           even and is N when is odd.
           See the Note below for more details. Unchanged on exit.
[in,out]B
          B is DOUBLE PRECISION array, dimension (LDB,N)
           Before entry,  the leading  m by n part of the array  B must
           contain  the  right-hand  side  matrix  B,  and  on exit  is
           overwritten by the solution matrix  X.
[in]LDB
          LDB is INTEGER
           On entry, LDB specifies the first dimension of B as declared
           in  the  calling  (sub)  program.   LDB  must  be  at  least
           max( 1, m ).
           Unchanged on exit.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
  We first consider Rectangular Full Packed (RFP) Format when N is
  even. We give an example where N = 6.

      AP is Upper             AP is Lower

   00 01 02 03 04 05       00
      11 12 13 14 15       10 11
         22 23 24 25       20 21 22
            33 34 35       30 31 32 33
               44 45       40 41 42 43 44
                  55       50 51 52 53 54 55


  Let TRANSR = 'N'. RFP holds AP as follows:
  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
  the transpose of the first three columns of AP upper.
  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
  the transpose of the last three columns of AP lower.
  This covers the case N even and TRANSR = 'N'.

         RFP A                   RFP A

        03 04 05                33 43 53
        13 14 15                00 44 54
        23 24 25                10 11 55
        33 34 35                20 21 22
        00 44 45                30 31 32
        01 11 55                40 41 42
        02 12 22                50 51 52

  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
  transpose of RFP A above. One therefore gets:


           RFP A                   RFP A

     03 13 23 33 00 01 02    33 00 10 20 30 40 50
     04 14 24 34 44 11 12    43 44 11 21 31 41 51
     05 15 25 35 45 55 22    53 54 55 22 32 42 52


  We then consider Rectangular Full Packed (RFP) Format when N is
  odd. We give an example where N = 5.

     AP is Upper                 AP is Lower

   00 01 02 03 04              00
      11 12 13 14              10 11
         22 23 24              20 21 22
            33 34              30 31 32 33
               44              40 41 42 43 44


  Let TRANSR = 'N'. RFP holds AP as follows:
  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
  the transpose of the first two columns of AP upper.
  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
  the transpose of the last two columns of AP lower.
  This covers the case N odd and TRANSR = 'N'.

         RFP A                   RFP A

        02 03 04                00 33 43
        12 13 14                10 11 44
        22 23 24                20 21 22
        00 33 34                30 31 32
        01 11 44                40 41 42

  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
  transpose of RFP A above. One therefore gets:

           RFP A                   RFP A

     02 12 22 00 01             00 10 20 30 40 50
     03 13 23 33 11             33 11 21 31 41 51
     04 14 24 34 44             43 44 22 32 42 52

Definition at line 275 of file dtfsm.f.

277*
278* -- LAPACK computational routine --
279* -- LAPACK is a software package provided by Univ. of Tennessee, --
280* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
281*
282* .. Scalar Arguments ..
283 CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO
284 INTEGER LDB, M, N
285 DOUBLE PRECISION ALPHA
286* ..
287* .. Array Arguments ..
288 DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * )
289* ..
290*
291* =====================================================================
292*
293* ..
294* .. Parameters ..
295 DOUBLE PRECISION ONE, ZERO
296 parameter( one = 1.0d+0, zero = 0.0d+0 )
297* ..
298* .. Local Scalars ..
299 LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR,
300 $ NOTRANS
301 INTEGER M1, M2, N1, N2, K, INFO, I, J
302* ..
303* .. External Functions ..
304 LOGICAL LSAME
305 EXTERNAL lsame
306* ..
307* .. External Subroutines ..
308 EXTERNAL xerbla, dgemm, dtrsm
309* ..
310* .. Intrinsic Functions ..
311 INTRINSIC max, mod
312* ..
313* .. Executable Statements ..
314*
315* Test the input parameters.
316*
317 info = 0
318 normaltransr = lsame( transr, 'N' )
319 lside = lsame( side, 'L' )
320 lower = lsame( uplo, 'L' )
321 notrans = lsame( trans, 'N' )
322 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'T' ) ) THEN
323 info = -1
324 ELSE IF( .NOT.lside .AND. .NOT.lsame( side, 'R' ) ) THEN
325 info = -2
326 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
327 info = -3
328 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'T' ) ) THEN
329 info = -4
330 ELSE IF( .NOT.lsame( diag, 'N' ) .AND. .NOT.lsame( diag, 'U' ) )
331 $ THEN
332 info = -5
333 ELSE IF( m.LT.0 ) THEN
334 info = -6
335 ELSE IF( n.LT.0 ) THEN
336 info = -7
337 ELSE IF( ldb.LT.max( 1, m ) ) THEN
338 info = -11
339 END IF
340 IF( info.NE.0 ) THEN
341 CALL xerbla( 'DTFSM ', -info )
342 RETURN
343 END IF
344*
345* Quick return when ( (N.EQ.0).OR.(M.EQ.0) )
346*
347 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
348 $ RETURN
349*
350* Quick return when ALPHA.EQ.(0D+0)
351*
352 IF( alpha.EQ.zero ) THEN
353 DO 20 j = 0, n - 1
354 DO 10 i = 0, m - 1
355 b( i, j ) = zero
356 10 CONTINUE
357 20 CONTINUE
358 RETURN
359 END IF
360*
361 IF( lside ) THEN
362*
363* SIDE = 'L'
364*
365* A is M-by-M.
366* If M is odd, set NISODD = .TRUE., and M1 and M2.
367* If M is even, NISODD = .FALSE., and M.
368*
369 IF( mod( m, 2 ).EQ.0 ) THEN
370 misodd = .false.
371 k = m / 2
372 ELSE
373 misodd = .true.
374 IF( lower ) THEN
375 m2 = m / 2
376 m1 = m - m2
377 ELSE
378 m1 = m / 2
379 m2 = m - m1
380 END IF
381 END IF
382*
383*
384 IF( misodd ) THEN
385*
386* SIDE = 'L' and N is odd
387*
388 IF( normaltransr ) THEN
389*
390* SIDE = 'L', N is odd, and TRANSR = 'N'
391*
392 IF( lower ) THEN
393*
394* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L'
395*
396 IF( notrans ) THEN
397*
398* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
399* TRANS = 'N'
400*
401 IF( m.EQ.1 ) THEN
402 CALL dtrsm( 'L', 'L', 'N', diag, m1, n, alpha,
403 $ a, m, b, ldb )
404 ELSE
405 CALL dtrsm( 'L', 'L', 'N', diag, m1, n, alpha,
406 $ a( 0 ), m, b, ldb )
407 CALL dgemm( 'N', 'N', m2, n, m1, -one, a( m1 ),
408 $ m, b, ldb, alpha, b( m1, 0 ), ldb )
409 CALL dtrsm( 'L', 'U', 'T', diag, m2, n, one,
410 $ a( m ), m, b( m1, 0 ), ldb )
411 END IF
412*
413 ELSE
414*
415* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
416* TRANS = 'T'
417*
418 IF( m.EQ.1 ) THEN
419 CALL dtrsm( 'L', 'L', 'T', diag, m1, n, alpha,
420 $ a( 0 ), m, b, ldb )
421 ELSE
422 CALL dtrsm( 'L', 'U', 'N', diag, m2, n, alpha,
423 $ a( m ), m, b( m1, 0 ), ldb )
424 CALL dgemm( 'T', 'N', m1, n, m2, -one, a( m1 ),
425 $ m, b( m1, 0 ), ldb, alpha, b, ldb )
426 CALL dtrsm( 'L', 'L', 'T', diag, m1, n, one,
427 $ a( 0 ), m, b, ldb )
428 END IF
429*
430 END IF
431*
432 ELSE
433*
434* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U'
435*
436 IF( .NOT.notrans ) THEN
437*
438* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
439* TRANS = 'N'
440*
441 CALL dtrsm( 'L', 'L', 'N', diag, m1, n, alpha,
442 $ a( m2 ), m, b, ldb )
443 CALL dgemm( 'T', 'N', m2, n, m1, -one, a( 0 ), m,
444 $ b, ldb, alpha, b( m1, 0 ), ldb )
445 CALL dtrsm( 'L', 'U', 'T', diag, m2, n, one,
446 $ a( m1 ), m, b( m1, 0 ), ldb )
447*
448 ELSE
449*
450* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
451* TRANS = 'T'
452*
453 CALL dtrsm( 'L', 'U', 'N', diag, m2, n, alpha,
454 $ a( m1 ), m, b( m1, 0 ), ldb )
455 CALL dgemm( 'N', 'N', m1, n, m2, -one, a( 0 ), m,
456 $ b( m1, 0 ), ldb, alpha, b, ldb )
457 CALL dtrsm( 'L', 'L', 'T', diag, m1, n, one,
458 $ a( m2 ), m, b, ldb )
459*
460 END IF
461*
462 END IF
463*
464 ELSE
465*
466* SIDE = 'L', N is odd, and TRANSR = 'T'
467*
468 IF( lower ) THEN
469*
470* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L'
471*
472 IF( notrans ) THEN
473*
474* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and
475* TRANS = 'N'
476*
477 IF( m.EQ.1 ) THEN
478 CALL dtrsm( 'L', 'U', 'T', diag, m1, n, alpha,
479 $ a( 0 ), m1, b, ldb )
480 ELSE
481 CALL dtrsm( 'L', 'U', 'T', diag, m1, n, alpha,
482 $ a( 0 ), m1, b, ldb )
483 CALL dgemm( 'T', 'N', m2, n, m1, -one,
484 $ a( m1*m1 ), m1, b, ldb, alpha,
485 $ b( m1, 0 ), ldb )
486 CALL dtrsm( 'L', 'L', 'N', diag, m2, n, one,
487 $ a( 1 ), m1, b( m1, 0 ), ldb )
488 END IF
489*
490 ELSE
491*
492* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and
493* TRANS = 'T'
494*
495 IF( m.EQ.1 ) THEN
496 CALL dtrsm( 'L', 'U', 'N', diag, m1, n, alpha,
497 $ a( 0 ), m1, b, ldb )
498 ELSE
499 CALL dtrsm( 'L', 'L', 'T', diag, m2, n, alpha,
500 $ a( 1 ), m1, b( m1, 0 ), ldb )
501 CALL dgemm( 'N', 'N', m1, n, m2, -one,
502 $ a( m1*m1 ), m1, b( m1, 0 ), ldb,
503 $ alpha, b, ldb )
504 CALL dtrsm( 'L', 'U', 'N', diag, m1, n, one,
505 $ a( 0 ), m1, b, ldb )
506 END IF
507*
508 END IF
509*
510 ELSE
511*
512* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U'
513*
514 IF( .NOT.notrans ) THEN
515*
516* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and
517* TRANS = 'N'
518*
519 CALL dtrsm( 'L', 'U', 'T', diag, m1, n, alpha,
520 $ a( m2*m2 ), m2, b, ldb )
521 CALL dgemm( 'N', 'N', m2, n, m1, -one, a( 0 ), m2,
522 $ b, ldb, alpha, b( m1, 0 ), ldb )
523 CALL dtrsm( 'L', 'L', 'N', diag, m2, n, one,
524 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
525*
526 ELSE
527*
528* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and
529* TRANS = 'T'
530*
531 CALL dtrsm( 'L', 'L', 'T', diag, m2, n, alpha,
532 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
533 CALL dgemm( 'T', 'N', m1, n, m2, -one, a( 0 ), m2,
534 $ b( m1, 0 ), ldb, alpha, b, ldb )
535 CALL dtrsm( 'L', 'U', 'N', diag, m1, n, one,
536 $ a( m2*m2 ), m2, b, ldb )
537*
538 END IF
539*
540 END IF
541*
542 END IF
543*
544 ELSE
545*
546* SIDE = 'L' and N is even
547*
548 IF( normaltransr ) THEN
549*
550* SIDE = 'L', N is even, and TRANSR = 'N'
551*
552 IF( lower ) THEN
553*
554* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L'
555*
556 IF( notrans ) THEN
557*
558* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
559* and TRANS = 'N'
560*
561 CALL dtrsm( 'L', 'L', 'N', diag, k, n, alpha,
562 $ a( 1 ), m+1, b, ldb )
563 CALL dgemm( 'N', 'N', k, n, k, -one, a( k+1 ),
564 $ m+1, b, ldb, alpha, b( k, 0 ), ldb )
565 CALL dtrsm( 'L', 'U', 'T', diag, k, n, one,
566 $ a( 0 ), m+1, b( k, 0 ), ldb )
567*
568 ELSE
569*
570* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
571* and TRANS = 'T'
572*
573 CALL dtrsm( 'L', 'U', 'N', diag, k, n, alpha,
574 $ a( 0 ), m+1, b( k, 0 ), ldb )
575 CALL dgemm( 'T', 'N', k, n, k, -one, a( k+1 ),
576 $ m+1, b( k, 0 ), ldb, alpha, b, ldb )
577 CALL dtrsm( 'L', 'L', 'T', diag, k, n, one,
578 $ a( 1 ), m+1, b, ldb )
579*
580 END IF
581*
582 ELSE
583*
584* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U'
585*
586 IF( .NOT.notrans ) THEN
587*
588* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
589* and TRANS = 'N'
590*
591 CALL dtrsm( 'L', 'L', 'N', diag, k, n, alpha,
592 $ a( k+1 ), m+1, b, ldb )
593 CALL dgemm( 'T', 'N', k, n, k, -one, a( 0 ), m+1,
594 $ b, ldb, alpha, b( k, 0 ), ldb )
595 CALL dtrsm( 'L', 'U', 'T', diag, k, n, one,
596 $ a( k ), m+1, b( k, 0 ), ldb )
597*
598 ELSE
599*
600* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
601* and TRANS = 'T'
602 CALL dtrsm( 'L', 'U', 'N', diag, k, n, alpha,
603 $ a( k ), m+1, b( k, 0 ), ldb )
604 CALL dgemm( 'N', 'N', k, n, k, -one, a( 0 ), m+1,
605 $ b( k, 0 ), ldb, alpha, b, ldb )
606 CALL dtrsm( 'L', 'L', 'T', diag, k, n, one,
607 $ a( k+1 ), m+1, b, ldb )
608*
609 END IF
610*
611 END IF
612*
613 ELSE
614*
615* SIDE = 'L', N is even, and TRANSR = 'T'
616*
617 IF( lower ) THEN
618*
619* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L'
620*
621 IF( notrans ) THEN
622*
623* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L',
624* and TRANS = 'N'
625*
626 CALL dtrsm( 'L', 'U', 'T', diag, k, n, alpha,
627 $ a( k ), k, b, ldb )
628 CALL dgemm( 'T', 'N', k, n, k, -one,
629 $ a( k*( k+1 ) ), k, b, ldb, alpha,
630 $ b( k, 0 ), ldb )
631 CALL dtrsm( 'L', 'L', 'N', diag, k, n, one,
632 $ a( 0 ), k, b( k, 0 ), ldb )
633*
634 ELSE
635*
636* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L',
637* and TRANS = 'T'
638*
639 CALL dtrsm( 'L', 'L', 'T', diag, k, n, alpha,
640 $ a( 0 ), k, b( k, 0 ), ldb )
641 CALL dgemm( 'N', 'N', k, n, k, -one,
642 $ a( k*( k+1 ) ), k, b( k, 0 ), ldb,
643 $ alpha, b, ldb )
644 CALL dtrsm( 'L', 'U', 'N', diag, k, n, one,
645 $ a( k ), k, b, ldb )
646*
647 END IF
648*
649 ELSE
650*
651* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U'
652*
653 IF( .NOT.notrans ) THEN
654*
655* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U',
656* and TRANS = 'N'
657*
658 CALL dtrsm( 'L', 'U', 'T', diag, k, n, alpha,
659 $ a( k*( k+1 ) ), k, b, ldb )
660 CALL dgemm( 'N', 'N', k, n, k, -one, a( 0 ), k, b,
661 $ ldb, alpha, b( k, 0 ), ldb )
662 CALL dtrsm( 'L', 'L', 'N', diag, k, n, one,
663 $ a( k*k ), k, b( k, 0 ), ldb )
664*
665 ELSE
666*
667* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U',
668* and TRANS = 'T'
669*
670 CALL dtrsm( 'L', 'L', 'T', diag, k, n, alpha,
671 $ a( k*k ), k, b( k, 0 ), ldb )
672 CALL dgemm( 'T', 'N', k, n, k, -one, a( 0 ), k,
673 $ b( k, 0 ), ldb, alpha, b, ldb )
674 CALL dtrsm( 'L', 'U', 'N', diag, k, n, one,
675 $ a( k*( k+1 ) ), k, b, ldb )
676*
677 END IF
678*
679 END IF
680*
681 END IF
682*
683 END IF
684*
685 ELSE
686*
687* SIDE = 'R'
688*
689* A is N-by-N.
690* If N is odd, set NISODD = .TRUE., and N1 and N2.
691* If N is even, NISODD = .FALSE., and K.
692*
693 IF( mod( n, 2 ).EQ.0 ) THEN
694 nisodd = .false.
695 k = n / 2
696 ELSE
697 nisodd = .true.
698 IF( lower ) THEN
699 n2 = n / 2
700 n1 = n - n2
701 ELSE
702 n1 = n / 2
703 n2 = n - n1
704 END IF
705 END IF
706*
707 IF( nisodd ) THEN
708*
709* SIDE = 'R' and N is odd
710*
711 IF( normaltransr ) THEN
712*
713* SIDE = 'R', N is odd, and TRANSR = 'N'
714*
715 IF( lower ) THEN
716*
717* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L'
718*
719 IF( notrans ) THEN
720*
721* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
722* TRANS = 'N'
723*
724 CALL dtrsm( 'R', 'U', 'T', diag, m, n2, alpha,
725 $ a( n ), n, b( 0, n1 ), ldb )
726 CALL dgemm( 'N', 'N', m, n1, n2, -one, b( 0, n1 ),
727 $ ldb, a( n1 ), n, alpha, b( 0, 0 ),
728 $ ldb )
729 CALL dtrsm( 'R', 'L', 'N', diag, m, n1, one,
730 $ a( 0 ), n, b( 0, 0 ), ldb )
731*
732 ELSE
733*
734* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
735* TRANS = 'T'
736*
737 CALL dtrsm( 'R', 'L', 'T', diag, m, n1, alpha,
738 $ a( 0 ), n, b( 0, 0 ), ldb )
739 CALL dgemm( 'N', 'T', m, n2, n1, -one, b( 0, 0 ),
740 $ ldb, a( n1 ), n, alpha, b( 0, n1 ),
741 $ ldb )
742 CALL dtrsm( 'R', 'U', 'N', diag, m, n2, one,
743 $ a( n ), n, b( 0, n1 ), ldb )
744*
745 END IF
746*
747 ELSE
748*
749* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U'
750*
751 IF( notrans ) THEN
752*
753* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
754* TRANS = 'N'
755*
756 CALL dtrsm( 'R', 'L', 'T', diag, m, n1, alpha,
757 $ a( n2 ), n, b( 0, 0 ), ldb )
758 CALL dgemm( 'N', 'N', m, n2, n1, -one, b( 0, 0 ),
759 $ ldb, a( 0 ), n, alpha, b( 0, n1 ),
760 $ ldb )
761 CALL dtrsm( 'R', 'U', 'N', diag, m, n2, one,
762 $ a( n1 ), n, b( 0, n1 ), ldb )
763*
764 ELSE
765*
766* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
767* TRANS = 'T'
768*
769 CALL dtrsm( 'R', 'U', 'T', diag, m, n2, alpha,
770 $ a( n1 ), n, b( 0, n1 ), ldb )
771 CALL dgemm( 'N', 'T', m, n1, n2, -one, b( 0, n1 ),
772 $ ldb, a( 0 ), n, alpha, b( 0, 0 ), ldb )
773 CALL dtrsm( 'R', 'L', 'N', diag, m, n1, one,
774 $ a( n2 ), n, b( 0, 0 ), ldb )
775*
776 END IF
777*
778 END IF
779*
780 ELSE
781*
782* SIDE = 'R', N is odd, and TRANSR = 'T'
783*
784 IF( lower ) THEN
785*
786* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L'
787*
788 IF( notrans ) THEN
789*
790* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and
791* TRANS = 'N'
792*
793 CALL dtrsm( 'R', 'L', 'N', diag, m, n2, alpha,
794 $ a( 1 ), n1, b( 0, n1 ), ldb )
795 CALL dgemm( 'N', 'T', m, n1, n2, -one, b( 0, n1 ),
796 $ ldb, a( n1*n1 ), n1, alpha, b( 0, 0 ),
797 $ ldb )
798 CALL dtrsm( 'R', 'U', 'T', diag, m, n1, one,
799 $ a( 0 ), n1, b( 0, 0 ), ldb )
800*
801 ELSE
802*
803* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and
804* TRANS = 'T'
805*
806 CALL dtrsm( 'R', 'U', 'N', diag, m, n1, alpha,
807 $ a( 0 ), n1, b( 0, 0 ), ldb )
808 CALL dgemm( 'N', 'N', m, n2, n1, -one, b( 0, 0 ),
809 $ ldb, a( n1*n1 ), n1, alpha, b( 0, n1 ),
810 $ ldb )
811 CALL dtrsm( 'R', 'L', 'T', diag, m, n2, one,
812 $ a( 1 ), n1, b( 0, n1 ), ldb )
813*
814 END IF
815*
816 ELSE
817*
818* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U'
819*
820 IF( notrans ) THEN
821*
822* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and
823* TRANS = 'N'
824*
825 CALL dtrsm( 'R', 'U', 'N', diag, m, n1, alpha,
826 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
827 CALL dgemm( 'N', 'T', m, n2, n1, -one, b( 0, 0 ),
828 $ ldb, a( 0 ), n2, alpha, b( 0, n1 ),
829 $ ldb )
830 CALL dtrsm( 'R', 'L', 'T', diag, m, n2, one,
831 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
832*
833 ELSE
834*
835* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and
836* TRANS = 'T'
837*
838 CALL dtrsm( 'R', 'L', 'N', diag, m, n2, alpha,
839 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
840 CALL dgemm( 'N', 'N', m, n1, n2, -one, b( 0, n1 ),
841 $ ldb, a( 0 ), n2, alpha, b( 0, 0 ),
842 $ ldb )
843 CALL dtrsm( 'R', 'U', 'T', diag, m, n1, one,
844 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
845*
846 END IF
847*
848 END IF
849*
850 END IF
851*
852 ELSE
853*
854* SIDE = 'R' and N is even
855*
856 IF( normaltransr ) THEN
857*
858* SIDE = 'R', N is even, and TRANSR = 'N'
859*
860 IF( lower ) THEN
861*
862* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L'
863*
864 IF( notrans ) THEN
865*
866* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
867* and TRANS = 'N'
868*
869 CALL dtrsm( 'R', 'U', 'T', diag, m, k, alpha,
870 $ a( 0 ), n+1, b( 0, k ), ldb )
871 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, k ),
872 $ ldb, a( k+1 ), n+1, alpha, b( 0, 0 ),
873 $ ldb )
874 CALL dtrsm( 'R', 'L', 'N', diag, m, k, one,
875 $ a( 1 ), n+1, b( 0, 0 ), ldb )
876*
877 ELSE
878*
879* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
880* and TRANS = 'T'
881*
882 CALL dtrsm( 'R', 'L', 'T', diag, m, k, alpha,
883 $ a( 1 ), n+1, b( 0, 0 ), ldb )
884 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, 0 ),
885 $ ldb, a( k+1 ), n+1, alpha, b( 0, k ),
886 $ ldb )
887 CALL dtrsm( 'R', 'U', 'N', diag, m, k, one,
888 $ a( 0 ), n+1, b( 0, k ), ldb )
889*
890 END IF
891*
892 ELSE
893*
894* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U'
895*
896 IF( notrans ) THEN
897*
898* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
899* and TRANS = 'N'
900*
901 CALL dtrsm( 'R', 'L', 'T', diag, m, k, alpha,
902 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
903 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, 0 ),
904 $ ldb, a( 0 ), n+1, alpha, b( 0, k ),
905 $ ldb )
906 CALL dtrsm( 'R', 'U', 'N', diag, m, k, one,
907 $ a( k ), n+1, b( 0, k ), ldb )
908*
909 ELSE
910*
911* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
912* and TRANS = 'T'
913*
914 CALL dtrsm( 'R', 'U', 'T', diag, m, k, alpha,
915 $ a( k ), n+1, b( 0, k ), ldb )
916 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, k ),
917 $ ldb, a( 0 ), n+1, alpha, b( 0, 0 ),
918 $ ldb )
919 CALL dtrsm( 'R', 'L', 'N', diag, m, k, one,
920 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
921*
922 END IF
923*
924 END IF
925*
926 ELSE
927*
928* SIDE = 'R', N is even, and TRANSR = 'T'
929*
930 IF( lower ) THEN
931*
932* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L'
933*
934 IF( notrans ) THEN
935*
936* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L',
937* and TRANS = 'N'
938*
939 CALL dtrsm( 'R', 'L', 'N', diag, m, k, alpha,
940 $ a( 0 ), k, b( 0, k ), ldb )
941 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, k ),
942 $ ldb, a( ( k+1 )*k ), k, alpha,
943 $ b( 0, 0 ), ldb )
944 CALL dtrsm( 'R', 'U', 'T', diag, m, k, one,
945 $ a( k ), k, b( 0, 0 ), ldb )
946*
947 ELSE
948*
949* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L',
950* and TRANS = 'T'
951*
952 CALL dtrsm( 'R', 'U', 'N', diag, m, k, alpha,
953 $ a( k ), k, b( 0, 0 ), ldb )
954 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, 0 ),
955 $ ldb, a( ( k+1 )*k ), k, alpha,
956 $ b( 0, k ), ldb )
957 CALL dtrsm( 'R', 'L', 'T', diag, m, k, one,
958 $ a( 0 ), k, b( 0, k ), ldb )
959*
960 END IF
961*
962 ELSE
963*
964* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U'
965*
966 IF( notrans ) THEN
967*
968* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U',
969* and TRANS = 'N'
970*
971 CALL dtrsm( 'R', 'U', 'N', diag, m, k, alpha,
972 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
973 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, 0 ),
974 $ ldb, a( 0 ), k, alpha, b( 0, k ), ldb )
975 CALL dtrsm( 'R', 'L', 'T', diag, m, k, one,
976 $ a( k*k ), k, b( 0, k ), ldb )
977*
978 ELSE
979*
980* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U',
981* and TRANS = 'T'
982*
983 CALL dtrsm( 'R', 'L', 'N', diag, m, k, alpha,
984 $ a( k*k ), k, b( 0, k ), ldb )
985 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, k ),
986 $ ldb, a( 0 ), k, alpha, b( 0, 0 ), ldb )
987 CALL dtrsm( 'R', 'U', 'T', diag, m, k, one,
988 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
989*
990 END IF
991*
992 END IF
993*
994 END IF
995*
996 END IF
997 END IF
998*
999 RETURN
1000*
1001* End of DTFSM
1002*
subroutine xerbla(srname, info)
Definition cblat2.f:3285
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:188
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181
Here is the call graph for this function:
Here is the caller graph for this function: