LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ csytrs_aa()

subroutine csytrs_aa ( character  UPLO,
integer  N,
integer  NRHS,
complex, dimension( lda, * )  A,
integer  LDA,
integer, dimension( * )  IPIV,
complex, dimension( ldb, * )  B,
integer  LDB,
complex, dimension( * )  WORK,
integer  LWORK,
integer  INFO 
)

CSYTRS_AA

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

Purpose:
 CSYTRS_AA solves a system of linear equations A*X = B with a complex
 symmetric matrix A using the factorization A = U**T*T*U or
 A = L*T*L**T computed by CSYTRF_AA.
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 = U**T*T*U;
          = 'L':  Lower triangular, form is A = L*T*L**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)
          Details of factors computed by CSYTRF_AA.
[in]LDA
          LDA is INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).
[in]IPIV
          IPIV is INTEGER array, dimension (N)
          Details of the interchanges as computed by CSYTRF_AA.
[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]WORK
          WORK is COMPLEX array, dimension (MAX(1,LWORK))
[in]LWORK
          LWORK is INTEGER
          The dimension of the array WORK. LWORK >= max(1,3*N-2).
[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.
Date
November 2017

Definition at line 133 of file csytrs_aa.f.

133 *
134 * -- LAPACK computational routine (version 3.8.0) --
135 * -- LAPACK is a software package provided by Univ. of Tennessee, --
136 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
137 * November 2017
138 *
139  IMPLICIT NONE
140 *
141 * .. Scalar Arguments ..
142  CHARACTER UPLO
143  INTEGER N, NRHS, LDA, LDB, LWORK, INFO
144 * ..
145 * .. Array Arguments ..
146  INTEGER IPIV( * )
147  COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
148 * ..
149 *
150 * =====================================================================
151 *
152  COMPLEX ONE
153  parameter( one = 1.0e+0 )
154 * ..
155 * .. Local Scalars ..
156  LOGICAL LQUERY, UPPER
157  INTEGER K, KP, LWKOPT
158 * ..
159 * .. External Functions ..
160  LOGICAL LSAME
161  EXTERNAL lsame
162 * ..
163 * .. External Subroutines ..
164  EXTERNAL clacpy, cgtsv, cswap, ctrsm, xerbla
165 * ..
166 * .. Intrinsic Functions ..
167  INTRINSIC max
168 * ..
169 * .. Executable Statements ..
170 *
171  info = 0
172  upper = lsame( uplo, 'U' )
173  lquery = ( lwork.EQ.-1 )
174  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
175  info = -1
176  ELSE IF( n.LT.0 ) THEN
177  info = -2
178  ELSE IF( nrhs.LT.0 ) THEN
179  info = -3
180  ELSE IF( lda.LT.max( 1, n ) ) THEN
181  info = -5
182  ELSE IF( ldb.LT.max( 1, n ) ) THEN
183  info = -8
184  ELSE IF( lwork.LT.max( 1, 3*n-2 ) .AND. .NOT.lquery ) THEN
185  info = -10
186  END IF
187  IF( info.NE.0 ) THEN
188  CALL xerbla( 'CSYTRS_AA', -info )
189  RETURN
190  ELSE IF( lquery ) THEN
191  lwkopt = (3*n-2)
192  work( 1 ) = lwkopt
193  RETURN
194  END IF
195 *
196 * Quick return if possible
197 *
198  IF( n.EQ.0 .OR. nrhs.EQ.0 )
199  $ RETURN
200 *
201  IF( upper ) THEN
202 *
203 * Solve A*X = B, where A = U**T*T*U.
204 *
205 * 1) Forward substitution with U**T
206 *
207  IF( n.GT.1 ) THEN
208 *
209 * Pivot, P**T * B -> B
210 *
211  DO k = 1, n
212  kp = ipiv( k )
213  IF( kp.NE.k )
214  $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
215  END DO
216 *
217 * Compute U**T \ B -> B [ (U**T \P**T * B) ]
218 *
219  CALL ctrsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),
220  $ lda, b( 2, 1 ), ldb)
221  END IF
222 *
223 * 2) Solve with triangular matrix T
224 *
225 * Compute T \ B -> B [ T \ (U**T \P**T * B) ]
226 *
227  CALL clacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1)
228  IF( n.GT.1 ) THEN
229  CALL clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 )
230  CALL clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 )
231  END IF
232  CALL cgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,
233  $ info )
234 *
235 * 3) Backward substitution with U
236 *
237  IF( n.GT.1 ) THEN
238 *
239 * Compute U \ B -> B [ U \ (T \ (U**T \P**T * B) ) ]
240 *
241  CALL ctrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),
242  $ lda, b( 2, 1 ), ldb)
243 *
244 * Pivot, P * B -> B [ P * (U**T \ (T \ (U \P**T * B) )) ]
245 *
246  DO k = n, 1, -1
247  kp = ipiv( k )
248  IF( kp.NE.k )
249  $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
250  END DO
251  END IF
252 *
253  ELSE
254 *
255 * Solve A*X = B, where A = L*T*L**T.
256 *
257 * 1) Forward substitution with L
258 *
259  IF( n.GT.1 ) THEN
260 *
261 * Pivot, P**T * B -> B
262 *
263  DO k = 1, n
264  kp = ipiv( k )
265  IF( kp.NE.k )
266  $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
267  END DO
268 *
269 * Compute L \ B -> B [ (L \P**T * B) ]
270 *
271  CALL ctrsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1 ),
272  $ lda, b( 2, 1 ), ldb)
273  END IF
274 *
275 * 2) Solve with triangular matrix T
276 *
277 *
278 * Compute T \ B -> B [ T \ (L \P**T * B) ]
279 *
280  CALL clacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
281  IF( n.GT.1 ) THEN
282  CALL clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 )
283  CALL clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 )
284  END IF
285  CALL cgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,
286  $ info)
287 *
288 * 3) Backward substitution with L**T
289 *
290  IF( n.GT.1 ) THEN
291 *
292 * Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
293 *
294  CALL ctrsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),
295  $ lda, b( 2, 1 ), ldb)
296 *
297 * Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
298 *
299  DO k = n, 1, -1
300  kp = ipiv( k )
301  IF( kp.NE.k )
302  $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
303  END DO
304  END IF
305 *
306  END IF
307 *
308  RETURN
309 *
310 * End of CSYTRS_AA
311 *
Here is the call graph for this function:
Here is the caller graph for this function:
ctrsm
subroutine ctrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRSM
Definition: ctrsm.f:182
clacpy
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
cswap
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
Definition: cswap.f:83
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
cgtsv
subroutine cgtsv(N, NRHS, DL, D, DU, B, LDB, INFO)
CGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition: cgtsv.f:126