LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ ssytrs_aa()

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

SSYTRS_AA

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

Purpose:
 SSYTRS_AA solves a system of linear equations A*X = B with a real
 symmetric matrix A using the factorization A = U**T*T*U or
 A = L*T*L**T computed by SSYTRF_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 REAL array, dimension (LDA,N)
          Details of factors computed by SSYTRF_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 SSYTRF_AA.
[in,out]B
          B is REAL 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 REAL 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 ssytrs_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  REAL A( LDA, * ), B( LDB, * ), WORK( * )
148 * ..
149 *
150 * =====================================================================
151 *
152  REAL 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 sgtsv, sswap, slacpy, strsm, 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( 'SSYTRS_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  k = 1
212  DO WHILE ( k.LE.n )
213  kp = ipiv( k )
214  IF( kp.NE.k )
215  $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
216  k = k + 1
217  END DO
218 *
219 * Compute U**T \ B -> B [ (U**T \P**T * B) ]
220 *
221  CALL strsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),
222  $ lda, b( 2, 1 ), ldb)
223  END IF
224 *
225 * 2) Solve with triangular matrix T
226 *
227 * Compute T \ B -> B [ T \ (U**T \P**T * B) ]
228 *
229  CALL slacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
230  IF( n.GT.1 ) THEN
231  CALL slacpy( 'F', 1, n-1, a(1, 2), lda+1, work(1), 1)
232  CALL slacpy( 'F', 1, n-1, a(1, 2), lda+1, work(2*n), 1)
233  END IF
234  CALL sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,
235  $ info)
236 *
237 * 3) Backward substitution with U
238 *
239  IF( n.GT.1 ) THEN
240 *
241 *
242 * Compute U \ B -> B [ U \ (T \ (U**T \P**T * B) ) ]
243 *
244  CALL strsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),
245  $ lda, b(2, 1), ldb)
246 *
247 * Pivot, P * B -> B [ P * (U \ (T \ (U**T \P**T * B) )) ]
248 *
249  k = n
250  DO WHILE ( k.GE.1 )
251  kp = ipiv( k )
252  IF( kp.NE.k )
253  $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
254  k = k - 1
255  END DO
256  END IF
257 *
258  ELSE
259 *
260 * Solve A*X = B, where A = L*T*L**T.
261 *
262 * 1) Forward substitution with L
263 *
264  IF( n.GT.1 ) THEN
265 *
266 * Pivot, P**T * B -> B
267 *
268  k = 1
269  DO WHILE ( k.LE.n )
270  kp = ipiv( k )
271  IF( kp.NE.k )
272  $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
273  k = k + 1
274  END DO
275 *
276 * Compute L \ B -> B [ (L \P**T * B) ]
277 *
278  CALL strsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1),
279  $ lda, b(2, 1), ldb)
280  END IF
281 *
282 * 2) Solve with triangular matrix T
283 *
284 * Compute T \ B -> B [ T \ (L \P**T * B) ]
285 *
286  CALL slacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
287  IF( n.GT.1 ) THEN
288  CALL slacpy( 'F', 1, n-1, a(2, 1), lda+1, work(1), 1)
289  CALL slacpy( 'F', 1, n-1, a(2, 1), lda+1, work(2*n), 1)
290  END IF
291  CALL sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,
292  $ info)
293 *
294 * 3) Backward substitution with L**T
295 *
296  IF( n.GT.1 ) THEN
297 *
298 * Compute L**T \ B -> B [ L**T \ (T \ (L \P**T * B) ) ]
299 *
300  CALL strsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),
301  $ lda, b( 2, 1 ), ldb)
302 *
303 * Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
304 *
305  k = n
306  DO WHILE ( k.GE.1 )
307  kp = ipiv( k )
308  IF( kp.NE.k )
309  $ CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
310  k = k - 1
311  END DO
312  END IF
313 *
314  END IF
315 *
316  RETURN
317 *
318 * End of SSYTRS_AA
319 *
Here is the call graph for this function:
Here is the caller graph for this function:
sswap
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
Definition: sswap.f:84
sgtsv
subroutine sgtsv(N, NRHS, DL, D, DU, B, LDB, INFO)
SGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition: sgtsv.f:129
slacpy
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
strsm
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
Definition: strsm.f:183
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55