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

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