LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ ctfsm()

subroutine ctfsm ( character  TRANSR,
character  SIDE,
character  UPLO,
character  TRANS,
character  DIAG,
integer  M,
integer  N,
complex  ALPHA,
complex, dimension( 0: * )  A,
complex, dimension( 0: ldb-1, 0: * )  B,
integer  LDB 
)

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

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

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

 CTFSM 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
           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 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 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 ctfsm.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 ALPHA
307 * ..
308 * .. Array Arguments ..
309  COMPLEX A( 0: * ), B( 0: LDB-1, 0: * )
310 * ..
311 *
312 * =====================================================================
313 * ..
314 * .. Parameters ..
315  COMPLEX CONE, CZERO
316  parameter( cone = ( 1.0e+0, 0.0e+0 ),
317  $ czero = ( 0.0e+0, 0.0e+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, cgemm, ctrsm
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( 'CTFSM ', -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.(0E+0,0E+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 ctrsm( 'L', 'L', 'N', diag, m1, n, alpha,
423  $ a, m, b, ldb )
424  ELSE
425  CALL ctrsm( 'L', 'L', 'N', diag, m1, n, alpha,
426  $ a( 0 ), m, b, ldb )
427  CALL cgemm( 'N', 'N', m2, n, m1, -cone, a( m1 ),
428  $ m, b, ldb, alpha, b( m1, 0 ), ldb )
429  CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, m1, n, alpha,
440  $ a( 0 ), m, b, ldb )
441  ELSE
442  CALL ctrsm( 'L', 'U', 'N', diag, m2, n, alpha,
443  $ a( m ), m, b( m1, 0 ), ldb )
444  CALL cgemm( 'C', 'N', m1, n, m2, -cone, a( m1 ),
445  $ m, b( m1, 0 ), ldb, alpha, b, ldb )
446  CALL ctrsm( '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 ctrsm( 'L', 'L', 'N', diag, m1, n, alpha,
462  $ a( m2 ), m, b, ldb )
463  CALL cgemm( 'C', 'N', m2, n, m1, -cone, a( 0 ), m,
464  $ b, ldb, alpha, b( m1, 0 ), ldb )
465  CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, m2, n, alpha,
474  $ a( m1 ), m, b( m1, 0 ), ldb )
475  CALL cgemm( 'N', 'N', m1, n, m2, -cone, a( 0 ), m,
476  $ b( m1, 0 ), ldb, alpha, b, ldb )
477  CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, m1, n, alpha,
499  $ a( 0 ), m1, b, ldb )
500  ELSE
501  CALL ctrsm( 'L', 'U', 'C', diag, m1, n, alpha,
502  $ a( 0 ), m1, b, ldb )
503  CALL cgemm( 'C', 'N', m2, n, m1, -cone,
504  $ a( m1*m1 ), m1, b, ldb, alpha,
505  $ b( m1, 0 ), ldb )
506  CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, m1, n, alpha,
517  $ a( 0 ), m1, b, ldb )
518  ELSE
519  CALL ctrsm( 'L', 'L', 'C', diag, m2, n, alpha,
520  $ a( 1 ), m1, b( m1, 0 ), ldb )
521  CALL cgemm( 'N', 'N', m1, n, m2, -cone,
522  $ a( m1*m1 ), m1, b( m1, 0 ), ldb,
523  $ alpha, b, ldb )
524  CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, m1, n, alpha,
540  $ a( m2*m2 ), m2, b, ldb )
541  CALL cgemm( 'N', 'N', m2, n, m1, -cone, a( 0 ), m2,
542  $ b, ldb, alpha, b( m1, 0 ), ldb )
543  CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, m2, n, alpha,
552  $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
553  CALL cgemm( 'C', 'N', m1, n, m2, -cone, a( 0 ), m2,
554  $ b( m1, 0 ), ldb, alpha, b, ldb )
555  CALL ctrsm( '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 ctrsm( 'L', 'L', 'N', diag, k, n, alpha,
582  $ a( 1 ), m+1, b, ldb )
583  CALL cgemm( 'N', 'N', k, n, k, -cone, a( k+1 ),
584  $ m+1, b, ldb, alpha, b( k, 0 ), ldb )
585  CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, k, n, alpha,
594  $ a( 0 ), m+1, b( k, 0 ), ldb )
595  CALL cgemm( 'C', 'N', k, n, k, -cone, a( k+1 ),
596  $ m+1, b( k, 0 ), ldb, alpha, b, ldb )
597  CALL ctrsm( '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 ctrsm( 'L', 'L', 'N', diag, k, n, alpha,
612  $ a( k+1 ), m+1, b, ldb )
613  CALL cgemm( 'C', 'N', k, n, k, -cone, a( 0 ), m+1,
614  $ b, ldb, alpha, b( k, 0 ), ldb )
615  CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, k, n, alpha,
623  $ a( k ), m+1, b( k, 0 ), ldb )
624  CALL cgemm( 'N', 'N', k, n, k, -cone, a( 0 ), m+1,
625  $ b( k, 0 ), ldb, alpha, b, ldb )
626  CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, k, n, alpha,
647  $ a( k ), k, b, ldb )
648  CALL cgemm( 'C', 'N', k, n, k, -cone,
649  $ a( k*( k+1 ) ), k, b, ldb, alpha,
650  $ b( k, 0 ), ldb )
651  CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, k, n, alpha,
660  $ a( 0 ), k, b( k, 0 ), ldb )
661  CALL cgemm( 'N', 'N', k, n, k, -cone,
662  $ a( k*( k+1 ) ), k, b( k, 0 ), ldb,
663  $ alpha, b, ldb )
664  CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, k, n, alpha,
679  $ a( k*( k+1 ) ), k, b, ldb )
680  CALL cgemm( 'N', 'N', k, n, k, -cone, a( 0 ), k, b,
681  $ ldb, alpha, b( k, 0 ), ldb )
682  CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, k, n, alpha,
691  $ a( k*k ), k, b( k, 0 ), ldb )
692  CALL cgemm( 'C', 'N', k, n, k, -cone, a( 0 ), k,
693  $ b( k, 0 ), ldb, alpha, b, ldb )
694  CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, n2, alpha,
745  $ a( n ), n, b( 0, n1 ), ldb )
746  CALL cgemm( 'N', 'N', m, n1, n2, -cone, b( 0, n1 ),
747  $ ldb, a( n1 ), n, alpha, b( 0, 0 ),
748  $ ldb )
749  CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, n1, alpha,
758  $ a( 0 ), n, b( 0, 0 ), ldb )
759  CALL cgemm( 'N', 'C', m, n2, n1, -cone, b( 0, 0 ),
760  $ ldb, a( n1 ), n, alpha, b( 0, n1 ),
761  $ ldb )
762  CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, n1, alpha,
777  $ a( n2 ), n, b( 0, 0 ), ldb )
778  CALL cgemm( 'N', 'N', m, n2, n1, -cone, b( 0, 0 ),
779  $ ldb, a( 0 ), n, alpha, b( 0, n1 ),
780  $ ldb )
781  CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, n2, alpha,
790  $ a( n1 ), n, b( 0, n1 ), ldb )
791  CALL cgemm( 'N', 'C', m, n1, n2, -cone, b( 0, n1 ),
792  $ ldb, a( 0 ), n, alpha, b( 0, 0 ), ldb )
793  CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, n2, alpha,
814  $ a( 1 ), n1, b( 0, n1 ), ldb )
815  CALL cgemm( 'N', 'C', m, n1, n2, -cone, b( 0, n1 ),
816  $ ldb, a( n1*n1 ), n1, alpha, b( 0, 0 ),
817  $ ldb )
818  CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, n1, alpha,
827  $ a( 0 ), n1, b( 0, 0 ), ldb )
828  CALL cgemm( 'N', 'N', m, n2, n1, -cone, b( 0, 0 ),
829  $ ldb, a( n1*n1 ), n1, alpha, b( 0, n1 ),
830  $ ldb )
831  CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, n1, alpha,
846  $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
847  CALL cgemm( 'N', 'C', m, n2, n1, -cone, b( 0, 0 ),
848  $ ldb, a( 0 ), n2, alpha, b( 0, n1 ),
849  $ ldb )
850  CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, n2, alpha,
859  $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
860  CALL cgemm( 'N', 'N', m, n1, n2, -cone, b( 0, n1 ),
861  $ ldb, a( 0 ), n2, alpha, b( 0, 0 ),
862  $ ldb )
863  CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, k, alpha,
890  $ a( 0 ), n+1, b( 0, k ), ldb )
891  CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
892  $ ldb, a( k+1 ), n+1, alpha, b( 0, 0 ),
893  $ ldb )
894  CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, k, alpha,
903  $ a( 1 ), n+1, b( 0, 0 ), ldb )
904  CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
905  $ ldb, a( k+1 ), n+1, alpha, b( 0, k ),
906  $ ldb )
907  CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, k, alpha,
922  $ a( k+1 ), n+1, b( 0, 0 ), ldb )
923  CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
924  $ ldb, a( 0 ), n+1, alpha, b( 0, k ),
925  $ ldb )
926  CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, k, alpha,
935  $ a( k ), n+1, b( 0, k ), ldb )
936  CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
937  $ ldb, a( 0 ), n+1, alpha, b( 0, 0 ),
938  $ ldb )
939  CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, k, alpha,
960  $ a( 0 ), k, b( 0, k ), ldb )
961  CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
962  $ ldb, a( ( k+1 )*k ), k, alpha,
963  $ b( 0, 0 ), ldb )
964  CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, k, alpha,
973  $ a( k ), k, b( 0, 0 ), ldb )
974  CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
975  $ ldb, a( ( k+1 )*k ), k, alpha,
976  $ b( 0, k ), ldb )
977  CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, k, alpha,
992  $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
993  CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
994  $ ldb, a( 0 ), k, alpha, b( 0, k ), ldb )
995  CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, k, alpha,
1004  $ a( k*k ), k, b( 0, k ), ldb )
1005  CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
1006  $ ldb, a( 0 ), k, alpha, b( 0, 0 ), ldb )
1007  CALL ctrsm( '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 CTFSM
1022 *
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:187
subroutine ctrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRSM
Definition: ctrsm.f:180
Here is the call graph for this function:
Here is the caller graph for this function: