csytrs_3()

subroutine csytrs_3	(	character	uplo,
		integer	n,
		integer	nrhs,
		complex, dimension( lda, * )	a,
		integer	lda,
		complex, dimension( * )	e,
		integer, dimension( * )	ipiv,
		complex, dimension( ldb, * )	b,
		integer	ldb,
		integer	info )

CSYTRS_3

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

Purpose:

!> CSYTRS_3 solves a system of linear equations A * X = B with a complex
!> symmetric matrix A using the factorization computed
!> by CSYTRF_RK or CSYTRF_BK:
!>
!>    A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**T (or L**T) is the transpose of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is symmetric and block
!> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> This algorithm is using Level 3 BLAS.
!> 

Parameters

[in]	UPLO	!> UPLO is CHARACTER*1 !> Specifies whether the details of the factorization are !> stored as an upper or lower triangular matrix: !> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); !> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). !>
[in]	N	!> N is INTEGER !> The order of the matrix A. N >= 0. !>
[in]	NRHS	!> NRHS is INTEGER !> The number of right hand sides, i.e., the number of columns !> of the matrix B. NRHS >= 0. !>
[in]	A	!> A is COMPLEX array, dimension (LDA,N) !> Diagonal of the block diagonal matrix D and factors U or L !> as computed by CSYTRF_RK and CSYTRF_BK: !> a) ONLY diagonal elements of the symmetric block diagonal !> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); !> (superdiagonal (or subdiagonal) elements of D !> should be provided on entry in array E), and !> b) If UPLO = 'U': factor U in the superdiagonal part of A. !> If UPLO = 'L': factor L in the subdiagonal part of A. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,N). !>
[in]	E	!> E is COMPLEX array, dimension (N) !> On entry, contains the superdiagonal (or subdiagonal) !> elements of the symmetric block diagonal matrix D !> with 1-by-1 or 2-by-2 diagonal blocks, where !> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; !> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. !> !> NOTE: For 1-by-1 diagonal block D(k), where !> 1 <= k <= N, the element E(k) is not referenced in both !> UPLO = 'U' or UPLO = 'L' cases. !>
[in]	IPIV	!> IPIV is INTEGER array, dimension (N) !> Details of the interchanges and the block structure of D !> as determined by CSYTRF_RK or CSYTRF_BK. !>
[in,out]	B	!> B is COMPLEX array, dimension (LDB,NRHS) !> On entry, the right hand side matrix B. !> On exit, the solution matrix X. !>
[in]	LDB	!> LDB is INTEGER !> The leading dimension of the array B. LDB >= max(1,N). !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

!>
!>  June 2017,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!> 

Definition at line 161 of file csytrs_3.f.

*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * ), B( LDB, * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE
      parameter( one = ( 1.0e+0,0.0e+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, J, K, KP
      COMPLEX            AK, AKM1, AKM1K, BK, BKM1, DENOM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. External Subroutines ..
      EXTERNAL           cscal, cswap, ctrsm, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
      info = 0
      upper = lsame( uplo, 'U' )
      IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
         info = -1
      ELSE IF( n.LT.0 ) THEN
         info = -2
      ELSE IF( nrhs.LT.0 ) THEN
         info = -3
      ELSE IF( lda.LT.max( 1, n ) ) THEN
         info = -5
      ELSE IF( ldb.LT.max( 1, n ) ) THEN
         info = -9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'CSYTRS_3', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( n.EQ.0 .OR. nrhs.EQ.0 )
     $   RETURN
*
      IF( upper ) THEN
*
*        Begin Upper
*
*        Solve A*X = B, where A = U*D*U**T.
*
*        P**T * B
*
*        Interchange rows K and IPIV(K) of matrix B in the same order
*        that the formation order of IPIV(I) vector for Upper case.
*
*        (We can do the simple loop over IPIV with decrement -1,
*        since the ABS value of IPIV(I) represents the row index
*        of the interchange with row i in both 1x1 and 2x2 pivot cases)
*
         DO k = n, 1, -1
            kp = abs( ipiv( k ) )
            IF( kp.NE.k ) THEN
               CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
            END IF
         END DO
*
*        Compute (U \P**T * B) -> B    [ (U \P**T * B) ]
*
         CALL ctrsm( 'L', 'U', 'N', 'U', n, nrhs, one, a, lda, b,
     $               ldb )
*
*        Compute D \ B -> B   [ D \ (U \P**T * B) ]
*
         i = n
         DO WHILE ( i.GE.1 )
            IF( ipiv( i ).GT.0 ) THEN
               CALL cscal( nrhs, one / a( i, i ), b( i, 1 ), ldb )
            ELSE IF ( i.GT.1 ) THEN
               akm1k = e( i )
               akm1 = a( i-1, i-1 ) / akm1k
               ak = a( i, i ) / akm1k
               denom = akm1*ak - one
               DO j = 1, nrhs
                  bkm1 = b( i-1, j ) / akm1k
                  bk = b( i, j ) / akm1k
                  b( i-1, j ) = ( ak*bkm1-bk ) / denom
                  b( i, j ) = ( akm1*bk-bkm1 ) / denom
               END DO
               i = i - 1
            END IF
            i = i - 1
         END DO
*
*        Compute (U**T \ B) -> B   [ U**T \ (D \ (U \P**T * B) ) ]
*
         CALL ctrsm( 'L', 'U', 'T', 'U', n, nrhs, one, a, lda, b,
     $               ldb )
*
*        P * B  [ P * (U**T \ (D \ (U \P**T * B) )) ]
*
*        Interchange rows K and IPIV(K) of matrix B in reverse order
*        from the formation order of IPIV(I) vector for Upper case.
*
*        (We can do the simple loop over IPIV with increment 1,
*        since the ABS value of IPIV( I ) represents the row index
*        of the interchange with row i in both 1x1 and 2x2 pivot cases)
*
         DO k = 1, n, 1
            kp = abs( ipiv( k ) )
            IF( kp.NE.k ) THEN
               CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
            END IF
         END DO
*
      ELSE
*
*        Begin Lower
*
*        Solve A*X = B, where A = L*D*L**T.
*
*        P**T * B
*        Interchange rows K and IPIV(K) of matrix B in the same order
*        that the formation order of IPIV(I) vector for Lower case.
*
*        (We can do the simple loop over IPIV with increment 1,
*        since the ABS value of IPIV(I) represents the row index
*        of the interchange with row i in both 1x1 and 2x2 pivot cases)
*
         DO k = 1, n, 1
            kp = abs( ipiv( k ) )
            IF( kp.NE.k ) THEN
               CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
            END IF
         END DO
*
*        Compute (L \P**T * B) -> B    [ (L \P**T * B) ]
*
         CALL ctrsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b,
     $               ldb )
*
*        Compute D \ B -> B   [ D \ (L \P**T * B) ]
*
         i = 1
         DO WHILE ( i.LE.n )
            IF( ipiv( i ).GT.0 ) THEN
               CALL cscal( nrhs, one / a( i, i ), b( i, 1 ), ldb )
            ELSE IF( i.LT.n ) THEN
               akm1k = e( i )
               akm1 = a( i, i ) / akm1k
               ak = a( i+1, i+1 ) / akm1k
               denom = akm1*ak - one
               DO  j = 1, nrhs
                  bkm1 = b( i, j ) / akm1k
                  bk = b( i+1, j ) / akm1k
                  b( i, j ) = ( ak*bkm1-bk ) / denom
                  b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
               END DO
               i = i + 1
            END IF
            i = i + 1
         END DO
*
*        Compute (L**T \ B) -> B   [ L**T \ (D \ (L \P**T * B) ) ]
*
         CALL ctrsm('L', 'L', 'T', 'U', n, nrhs, one, a, lda, b,
     $               ldb )
*
*        P * B  [ P * (L**T \ (D \ (L \P**T * B) )) ]
*
*        Interchange rows K and IPIV(K) of matrix B in reverse order
*        from the formation order of IPIV(I) vector for Lower case.
*
*        (We can do the simple loop over IPIV with decrement -1,
*        since the ABS value of IPIV(I) represents the row index
*        of the interchange with row i in both 1x1 and 2x2 pivot cases)
*
         DO k = n, 1, -1
            kp = abs( ipiv( k ) )
            IF( kp.NE.k ) THEN
               CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
            END IF
         END DO
*
*        END Lower
*
      END IF
*
      RETURN
*
*     End of CSYTRS_3
*

Here is the call graph for this function:

Here is the caller graph for this function: