LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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.
Date
September 2012
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 300 of file ztfsm.f.

300 *
301 * -- LAPACK computational routine (version 3.4.2) --
302 * -- LAPACK is a software package provided by Univ. of Tennessee, --
303 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
304 * September 2012
305 *
306 * .. Scalar Arguments ..
307  CHARACTER transr, diag, side, trans, uplo
308  INTEGER ldb, m, n
309  COMPLEX*16 alpha
310 * ..
311 * .. Array Arguments ..
312  COMPLEX*16 a( 0: * ), b( 0: ldb-1, 0: * )
313 * ..
314 *
315 * =====================================================================
316 * ..
317 * .. Parameters ..
318  COMPLEX*16 cone, czero
319  parameter ( cone = ( 1.0d+0, 0.0d+0 ),
320  $ czero = ( 0.0d+0, 0.0d+0 ) )
321 * ..
322 * .. Local Scalars ..
323  LOGICAL lower, lside, misodd, nisodd, normaltransr,
324  $ notrans
325  INTEGER m1, m2, n1, n2, k, info, i, j
326 * ..
327 * .. External Functions ..
328  LOGICAL lsame
329  EXTERNAL lsame
330 * ..
331 * .. External Subroutines ..
332  EXTERNAL xerbla, zgemm, ztrsm
333 * ..
334 * .. Intrinsic Functions ..
335  INTRINSIC max, mod
336 * ..
337 * .. Executable Statements ..
338 *
339 * Test the input parameters.
340 *
341  info = 0
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
347  info = -1
348  ELSE IF( .NOT.lside .AND. .NOT.lsame( side, 'R' ) ) THEN
349  info = -2
350  ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
351  info = -3
352  ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'C' ) ) THEN
353  info = -4
354  ELSE IF( .NOT.lsame( diag, 'N' ) .AND. .NOT.lsame( diag, 'U' ) )
355  $ THEN
356  info = -5
357  ELSE IF( m.LT.0 ) THEN
358  info = -6
359  ELSE IF( n.LT.0 ) THEN
360  info = -7
361  ELSE IF( ldb.LT.max( 1, m ) ) THEN
362  info = -11
363  END IF
364  IF( info.NE.0 ) THEN
365  CALL xerbla( 'ZTFSM ', -info )
366  RETURN
367  END IF
368 *
369 * Quick return when ( (N.EQ.0).OR.(M.EQ.0) )
370 *
371  IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
372  $ RETURN
373 *
374 * Quick return when ALPHA.EQ.(0D+0,0D+0)
375 *
376  IF( alpha.EQ.czero ) THEN
377  DO 20 j = 0, n - 1
378  DO 10 i = 0, m - 1
379  b( i, j ) = czero
380  10 CONTINUE
381  20 CONTINUE
382  RETURN
383  END IF
384 *
385  IF( lside ) THEN
386 *
387 * SIDE = 'L'
388 *
389 * A is M-by-M.
390 * If M is odd, set NISODD = .TRUE., and M1 and M2.
391 * If M is even, NISODD = .FALSE., and M.
392 *
393  IF( mod( m, 2 ).EQ.0 ) THEN
394  misodd = .false.
395  k = m / 2
396  ELSE
397  misodd = .true.
398  IF( lower ) THEN
399  m2 = m / 2
400  m1 = m - m2
401  ELSE
402  m1 = m / 2
403  m2 = m - m1
404  END IF
405  END IF
406 *
407  IF( misodd ) THEN
408 *
409 * SIDE = 'L' and N is odd
410 *
411  IF( normaltransr ) THEN
412 *
413 * SIDE = 'L', N is odd, and TRANSR = 'N'
414 *
415  IF( lower ) THEN
416 *
417 * SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L'
418 *
419  IF( notrans ) THEN
420 *
421 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
422 * TRANS = 'N'
423 *
424  IF( m.EQ.1 ) THEN
425  CALL ztrsm( 'L', 'L', 'N', diag, m1, n, alpha,
426  $ a, m, b, ldb )
427  ELSE
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 )
434  END IF
435 *
436  ELSE
437 *
438 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
439 * TRANS = 'C'
440 *
441  IF( m.EQ.1 ) THEN
442  CALL ztrsm( 'L', 'L', 'C', diag, m1, n, alpha,
443  $ a( 0 ), m, b, ldb )
444  ELSE
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 )
451  END IF
452 *
453  END IF
454 *
455  ELSE
456 *
457 * SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U'
458 *
459  IF( .NOT.notrans ) THEN
460 *
461 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
462 * TRANS = 'N'
463 *
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 )
470 *
471  ELSE
472 *
473 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
474 * TRANS = 'C'
475 *
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 )
482 *
483  END IF
484 *
485  END IF
486 *
487  ELSE
488 *
489 * SIDE = 'L', N is odd, and TRANSR = 'C'
490 *
491  IF( lower ) THEN
492 *
493 * SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L'
494 *
495  IF( notrans ) THEN
496 *
497 * SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and
498 * TRANS = 'N'
499 *
500  IF( m.EQ.1 ) THEN
501  CALL ztrsm( 'L', 'U', 'C', diag, m1, n, alpha,
502  $ a( 0 ), m1, b, ldb )
503  ELSE
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,
508  $ b( m1, 0 ), ldb )
509  CALL ztrsm( 'L', 'L', 'N', diag, m2, n, cone,
510  $ a( 1 ), m1, b( m1, 0 ), ldb )
511  END IF
512 *
513  ELSE
514 *
515 * SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and
516 * TRANS = 'C'
517 *
518  IF( m.EQ.1 ) THEN
519  CALL ztrsm( 'L', 'U', 'N', diag, m1, n, alpha,
520  $ a( 0 ), m1, b, ldb )
521  ELSE
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,
526  $ alpha, b, ldb )
527  CALL ztrsm( 'L', 'U', 'N', diag, m1, n, cone,
528  $ a( 0 ), m1, b, ldb )
529  END IF
530 *
531  END IF
532 *
533  ELSE
534 *
535 * SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U'
536 *
537  IF( .NOT.notrans ) THEN
538 *
539 * SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and
540 * TRANS = 'N'
541 *
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 )
548 *
549  ELSE
550 *
551 * SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and
552 * TRANS = 'C'
553 *
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 )
560 *
561  END IF
562 *
563  END IF
564 *
565  END IF
566 *
567  ELSE
568 *
569 * SIDE = 'L' and N is even
570 *
571  IF( normaltransr ) THEN
572 *
573 * SIDE = 'L', N is even, and TRANSR = 'N'
574 *
575  IF( lower ) THEN
576 *
577 * SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L'
578 *
579  IF( notrans ) THEN
580 *
581 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
582 * and TRANS = 'N'
583 *
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 )
590 *
591  ELSE
592 *
593 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
594 * and TRANS = 'C'
595 *
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 )
602 *
603  END IF
604 *
605  ELSE
606 *
607 * SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U'
608 *
609  IF( .NOT.notrans ) THEN
610 *
611 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
612 * and TRANS = 'N'
613 *
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 )
620 *
621  ELSE
622 *
623 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
624 * and TRANS = 'C'
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 )
631 *
632  END IF
633 *
634  END IF
635 *
636  ELSE
637 *
638 * SIDE = 'L', N is even, and TRANSR = 'C'
639 *
640  IF( lower ) THEN
641 *
642 * SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L'
643 *
644  IF( notrans ) THEN
645 *
646 * SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L',
647 * and TRANS = 'N'
648 *
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,
653  $ b( k, 0 ), ldb )
654  CALL ztrsm( 'L', 'L', 'N', diag, k, n, cone,
655  $ a( 0 ), k, b( k, 0 ), ldb )
656 *
657  ELSE
658 *
659 * SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L',
660 * and TRANS = 'C'
661 *
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,
666  $ alpha, b, ldb )
667  CALL ztrsm( 'L', 'U', 'N', diag, k, n, cone,
668  $ a( k ), k, b, ldb )
669 *
670  END IF
671 *
672  ELSE
673 *
674 * SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U'
675 *
676  IF( .NOT.notrans ) THEN
677 *
678 * SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U',
679 * and TRANS = 'N'
680 *
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 )
687 *
688  ELSE
689 *
690 * SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U',
691 * and TRANS = 'C'
692 *
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 )
699 *
700  END IF
701 *
702  END IF
703 *
704  END IF
705 *
706  END IF
707 *
708  ELSE
709 *
710 * SIDE = 'R'
711 *
712 * A is N-by-N.
713 * If N is odd, set NISODD = .TRUE., and N1 and N2.
714 * If N is even, NISODD = .FALSE., and K.
715 *
716  IF( mod( n, 2 ).EQ.0 ) THEN
717  nisodd = .false.
718  k = n / 2
719  ELSE
720  nisodd = .true.
721  IF( lower ) THEN
722  n2 = n / 2
723  n1 = n - n2
724  ELSE
725  n1 = n / 2
726  n2 = n - n1
727  END IF
728  END IF
729 *
730  IF( nisodd ) THEN
731 *
732 * SIDE = 'R' and N is odd
733 *
734  IF( normaltransr ) THEN
735 *
736 * SIDE = 'R', N is odd, and TRANSR = 'N'
737 *
738  IF( lower ) THEN
739 *
740 * SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L'
741 *
742  IF( notrans ) THEN
743 *
744 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
745 * TRANS = 'N'
746 *
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 ),
751  $ ldb )
752  CALL ztrsm( 'R', 'L', 'N', diag, m, n1, cone,
753  $ a( 0 ), n, b( 0, 0 ), ldb )
754 *
755  ELSE
756 *
757 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
758 * TRANS = 'C'
759 *
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 ),
764  $ ldb )
765  CALL ztrsm( 'R', 'U', 'N', diag, m, n2, cone,
766  $ a( n ), n, b( 0, n1 ), ldb )
767 *
768  END IF
769 *
770  ELSE
771 *
772 * SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U'
773 *
774  IF( notrans ) THEN
775 *
776 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
777 * TRANS = 'N'
778 *
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 ),
783  $ ldb )
784  CALL ztrsm( 'R', 'U', 'N', diag, m, n2, cone,
785  $ a( n1 ), n, b( 0, n1 ), ldb )
786 *
787  ELSE
788 *
789 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
790 * TRANS = 'C'
791 *
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 )
798 *
799  END IF
800 *
801  END IF
802 *
803  ELSE
804 *
805 * SIDE = 'R', N is odd, and TRANSR = 'C'
806 *
807  IF( lower ) THEN
808 *
809 * SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L'
810 *
811  IF( notrans ) THEN
812 *
813 * SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and
814 * TRANS = 'N'
815 *
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 ),
820  $ ldb )
821  CALL ztrsm( 'R', 'U', 'C', diag, m, n1, cone,
822  $ a( 0 ), n1, b( 0, 0 ), ldb )
823 *
824  ELSE
825 *
826 * SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and
827 * TRANS = 'C'
828 *
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 ),
833  $ ldb )
834  CALL ztrsm( 'R', 'L', 'C', diag, m, n2, cone,
835  $ a( 1 ), n1, b( 0, n1 ), ldb )
836 *
837  END IF
838 *
839  ELSE
840 *
841 * SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U'
842 *
843  IF( notrans ) THEN
844 *
845 * SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and
846 * TRANS = 'N'
847 *
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 ),
852  $ ldb )
853  CALL ztrsm( 'R', 'L', 'C', diag, m, n2, cone,
854  $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
855 *
856  ELSE
857 *
858 * SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and
859 * TRANS = 'C'
860 *
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 ),
865  $ ldb )
866  CALL ztrsm( 'R', 'U', 'C', diag, m, n1, cone,
867  $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
868 *
869  END IF
870 *
871  END IF
872 *
873  END IF
874 *
875  ELSE
876 *
877 * SIDE = 'R' and N is even
878 *
879  IF( normaltransr ) THEN
880 *
881 * SIDE = 'R', N is even, and TRANSR = 'N'
882 *
883  IF( lower ) THEN
884 *
885 * SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L'
886 *
887  IF( notrans ) THEN
888 *
889 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
890 * and TRANS = 'N'
891 *
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 ),
896  $ ldb )
897  CALL ztrsm( 'R', 'L', 'N', diag, m, k, cone,
898  $ a( 1 ), n+1, b( 0, 0 ), ldb )
899 *
900  ELSE
901 *
902 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
903 * and TRANS = 'C'
904 *
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 ),
909  $ ldb )
910  CALL ztrsm( 'R', 'U', 'N', diag, m, k, cone,
911  $ a( 0 ), n+1, b( 0, k ), ldb )
912 *
913  END IF
914 *
915  ELSE
916 *
917 * SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U'
918 *
919  IF( notrans ) THEN
920 *
921 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
922 * and TRANS = 'N'
923 *
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 ),
928  $ ldb )
929  CALL ztrsm( 'R', 'U', 'N', diag, m, k, cone,
930  $ a( k ), n+1, b( 0, k ), ldb )
931 *
932  ELSE
933 *
934 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
935 * and TRANS = 'C'
936 *
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 ),
941  $ ldb )
942  CALL ztrsm( 'R', 'L', 'N', diag, m, k, cone,
943  $ a( k+1 ), n+1, b( 0, 0 ), ldb )
944 *
945  END IF
946 *
947  END IF
948 *
949  ELSE
950 *
951 * SIDE = 'R', N is even, and TRANSR = 'C'
952 *
953  IF( lower ) THEN
954 *
955 * SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L'
956 *
957  IF( notrans ) THEN
958 *
959 * SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L',
960 * and TRANS = 'N'
961 *
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,
966  $ b( 0, 0 ), ldb )
967  CALL ztrsm( 'R', 'U', 'C', diag, m, k, cone,
968  $ a( k ), k, b( 0, 0 ), ldb )
969 *
970  ELSE
971 *
972 * SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L',
973 * and TRANS = 'C'
974 *
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,
979  $ b( 0, k ), ldb )
980  CALL ztrsm( 'R', 'L', 'C', diag, m, k, cone,
981  $ a( 0 ), k, b( 0, k ), ldb )
982 *
983  END IF
984 *
985  ELSE
986 *
987 * SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U'
988 *
989  IF( notrans ) THEN
990 *
991 * SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U',
992 * and TRANS = 'N'
993 *
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 )
1000 *
1001  ELSE
1002 *
1003 * SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U',
1004 * and TRANS = 'C'
1005 *
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 )
1012 *
1013  END IF
1014 *
1015  END IF
1016 *
1017  END IF
1018 *
1019  END IF
1020  END IF
1021 *
1022  RETURN
1023 *
1024 * End of ZTFSM
1025 *
zgemm
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
Definition: zgemm.f:189
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
ztrsm
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
Definition: ztrsm.f:182
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55

Here is the call graph for this function:

Here is the caller graph for this function: