LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ zsytrs_aa()

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

ZSYTRS_AA

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

Purpose:
 ZSYTRS_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 ZSYTRF_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*16 array, dimension (LDA,N)
          Details of factors computed by ZSYTRF_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 ZSYTRF_AA.
[in,out]B
          B is COMPLEX*16 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*16 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 zsytrs_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*16 A( LDA, * ), B( LDB, * ), WORK( * )
148 * ..
149 *
150 * =====================================================================
151 *
152  COMPLEX*16 ONE
153  parameter( one = 1.0d+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 zgtsv, zswap, zlacpy, ztrsm, 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( 'ZSYTRS_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 zswap( 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 ztrsm( '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 zlacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1)
228  IF( n.GT.1 ) THEN
229  CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 )
230  CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 )
231  END IF
232  CALL zgtsv( 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 ztrsm( '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 \ (U**T \P**T * B) )) ]
245 *
246  DO k = n, 1, -1
247  kp = ipiv( k )
248  IF( kp.NE.k )
249  $ CALL zswap( 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 zswap( 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 ztrsm( '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 * Compute T \ B -> B [ T \ (L \P**T * B) ]
278 *
279  CALL zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
280  IF( n.GT.1 ) THEN
281  CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 )
282  CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 )
283  END IF
284  CALL zgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,
285  $ info)
286 *
287 * 3) Backward substitution with L**T
288 *
289  IF( n.GT.1 ) THEN
290 *
291 * Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
292 *
293  CALL ztrsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),
294  $ lda, b( 2, 1 ), ldb)
295 *
296 * Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
297 *
298  DO k = n, 1, -1
299  kp = ipiv( k )
300  IF( kp.NE.k )
301  $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
302  END DO
303  END IF
304 *
305  END IF
306 *
307  RETURN
308 *
309 * End of ZSYTRS_AA
310 *
Here is the call graph for this function:
Here is the caller graph for this function:
ztrsm
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
Definition: ztrsm.f:182
zgtsv
subroutine zgtsv(N, NRHS, DL, D, DU, B, LDB, INFO)
ZGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition: zgtsv.f:126
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
zswap
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
Definition: zswap.f:83