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

◆ ztfsm()

subroutine ztfsm ( character  transr,
character  side,
character  uplo,
character  trans,
character  diag,
integer  m,
integer  n,
complex*16  alpha,
complex*16, dimension( 0: * )  a,
complex*16, dimension( 0: ldb-1, 0: * )  b,
integer  ldb 
)

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

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

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

 ZTFSM  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**H.

 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;
          = 'C':  The Conjugate-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  = 'C' or 'c'   op( A ) = conjg( 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 COMPLEX*16
           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 COMPLEX*16 array, dimension (N*(N+1)/2)
           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 = 'C' then RFP is the Conjugate-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
           conjugate-transpose Format. If UPLO = 'L' the RFP A contains
           the NT elements of lower packed A either in normal or
           conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when
           TRANSR = 'C'. 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 COMPLEX*16 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 Standard Packed 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
  conjugate-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
  conjugate-transpose of the last three columns of AP lower.
  To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate-
  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 next  consider Standard Packed 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
  conjugate-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
  conjugate-transpose of the last two   columns of AP lower.
  To denote conjugate we place -- above the element. 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 = 'C'. RFP A in both UPLO cases is just the conjugate-
  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 296 of file ztfsm.f.

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