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

◆ 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.

Definition at line 127 of file zsytrs_aa.f.

129*
130* -- LAPACK computational routine --
131* -- LAPACK is a software package provided by Univ. of Tennessee, --
132* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
133*
134 IMPLICIT NONE
135*
136* .. Scalar Arguments ..
137 CHARACTER UPLO
138 INTEGER N, NRHS, LDA, LDB, LWORK, INFO
139* ..
140* .. Array Arguments ..
141 INTEGER IPIV( * )
142 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
143* ..
144*
145* =====================================================================
146*
147 COMPLEX*16 ONE
148 parameter( one = 1.0d+0 )
149* ..
150* .. Local Scalars ..
151 LOGICAL LQUERY, UPPER
152 INTEGER K, KP, LWKOPT
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 EXTERNAL lsame
157* ..
158* .. External Subroutines ..
159 EXTERNAL zgtsv, zswap, zlacpy, ztrsm, xerbla
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC max
163* ..
164* .. Executable Statements ..
165*
166 info = 0
167 upper = lsame( uplo, 'U' )
168 lquery = ( lwork.EQ.-1 )
169 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
170 info = -1
171 ELSE IF( n.LT.0 ) THEN
172 info = -2
173 ELSE IF( nrhs.LT.0 ) THEN
174 info = -3
175 ELSE IF( lda.LT.max( 1, n ) ) THEN
176 info = -5
177 ELSE IF( ldb.LT.max( 1, n ) ) THEN
178 info = -8
179 ELSE IF( lwork.LT.max( 1, 3*n-2 ) .AND. .NOT.lquery ) THEN
180 info = -10
181 END IF
182 IF( info.NE.0 ) THEN
183 CALL xerbla( 'ZSYTRS_AA', -info )
184 RETURN
185 ELSE IF( lquery ) THEN
186 lwkopt = (3*n-2)
187 work( 1 ) = lwkopt
188 RETURN
189 END IF
190*
191* Quick return if possible
192*
193 IF( n.EQ.0 .OR. nrhs.EQ.0 )
194 $ RETURN
195*
196 IF( upper ) THEN
197*
198* Solve A*X = B, where A = U**T*T*U.
199*
200* 1) Forward substitution with U**T
201*
202 IF( n.GT.1 ) THEN
203*
204* Pivot, P**T * B -> B
205*
206 DO k = 1, n
207 kp = ipiv( k )
208 IF( kp.NE.k )
209 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
210 END DO
211*
212* Compute U**T \ B -> B [ (U**T \P**T * B) ]
213*
214 CALL ztrsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1,
215 $ 2 ),
216 $ lda, b( 2, 1 ), ldb)
217 END IF
218*
219* 2) Solve with triangular matrix T
220*
221* Compute T \ B -> B [ T \ (U**T \P**T * B) ]
222*
223 CALL zlacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1)
224 IF( n.GT.1 ) THEN
225 CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ),
226 $ 1 )
227 CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ),
228 $ 1 )
229 END IF
230 CALL zgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b,
231 $ ldb,
232 $ info )
233*
234* 3) Backward substitution with U
235*
236 IF( n.GT.1 ) THEN
237*
238* Compute U \ B -> B [ U \ (T \ (U**T \P**T * B) ) ]
239*
240 CALL ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1,
241 $ 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,
272 $ 1 ),
273 $ lda, b( 2, 1 ), ldb)
274 END IF
275*
276* 2) Solve with triangular matrix T
277*
278* Compute T \ B -> B [ T \ (L \P**T * B) ]
279*
280 CALL zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
281 IF( n.GT.1 ) THEN
282 CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ),
283 $ 1 )
284 CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ),
285 $ 1 )
286 END IF
287 CALL zgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b,
288 $ ldb,
289 $ info)
290*
291* 3) Backward substitution with L**T
292*
293 IF( n.GT.1 ) THEN
294*
295* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
296*
297 CALL ztrsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2,
298 $ 1 ),
299 $ lda, b( 2, 1 ), ldb)
300*
301* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
302*
303 DO k = n, 1, -1
304 kp = ipiv( k )
305 IF( kp.NE.k )
306 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
307 END DO
308 END IF
309*
310 END IF
311*
312 RETURN
313*
314* End of ZSYTRS_AA
315*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
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:122
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:101
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
Here is the call graph for this function:
Here is the caller graph for this function: