LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
dsytrs_aa_2stage.f
Go to the documentation of this file.
1*> \brief \b DSYTRS_AA_2STAGE
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download DSYTRS_AA_2STAGE + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrs_aa_2stage.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrs_aa_2stage.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrs_aa_2stage.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE DSYTRS_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, IPIV,
22* IPIV2, B, LDB, INFO )
23*
24* .. Scalar Arguments ..
25* CHARACTER UPLO
26* INTEGER N, NRHS, LDA, LTB, LDB, INFO
27* ..
28* .. Array Arguments ..
29* INTEGER IPIV( * ), IPIV2( * )
30* DOUBLE PRECISION A( LDA, * ), TB( * ), B( LDB, * )
31* ..
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> DSYTRS_AA_2STAGE solves a system of linear equations A*X = B with a real
39*> symmetric matrix A using the factorization A = U**T*T*U or
40*> A = L*T*L**T computed by DSYTRF_AA_2STAGE.
41*> \endverbatim
42*
43* Arguments:
44* ==========
45*
46*> \param[in] UPLO
47*> \verbatim
48*> UPLO is CHARACTER*1
49*> Specifies whether the details of the factorization are stored
50*> as an upper or lower triangular matrix.
51*> = 'U': Upper triangular, form is A = U**T*T*U;
52*> = 'L': Lower triangular, form is A = L*T*L**T.
53*> \endverbatim
54*>
55*> \param[in] N
56*> \verbatim
57*> N is INTEGER
58*> The order of the matrix A. N >= 0.
59*> \endverbatim
60*>
61*> \param[in] NRHS
62*> \verbatim
63*> NRHS is INTEGER
64*> The number of right hand sides, i.e., the number of columns
65*> of the matrix B. NRHS >= 0.
66*> \endverbatim
67*>
68*> \param[in] A
69*> \verbatim
70*> A is DOUBLE PRECISION array, dimension (LDA,N)
71*> Details of factors computed by DSYTRF_AA_2STAGE.
72*> \endverbatim
73*>
74*> \param[in] LDA
75*> \verbatim
76*> LDA is INTEGER
77*> The leading dimension of the array A. LDA >= max(1,N).
78*> \endverbatim
79*>
80*> \param[out] TB
81*> \verbatim
82*> TB is DOUBLE PRECISION array, dimension (LTB)
83*> Details of factors computed by DSYTRF_AA_2STAGE.
84*> \endverbatim
85*>
86*> \param[in] LTB
87*> \verbatim
88*> LTB is INTEGER
89*> The size of the array TB. LTB >= 4*N.
90*> \endverbatim
91*>
92*> \param[in] IPIV
93*> \verbatim
94*> IPIV is INTEGER array, dimension (N)
95*> Details of the interchanges as computed by
96*> DSYTRF_AA_2STAGE.
97*> \endverbatim
98*>
99*> \param[in] IPIV2
100*> \verbatim
101*> IPIV2 is INTEGER array, dimension (N)
102*> Details of the interchanges as computed by
103*> DSYTRF_AA_2STAGE.
104*> \endverbatim
105*>
106*> \param[in,out] B
107*> \verbatim
108*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
109*> On entry, the right hand side matrix B.
110*> On exit, the solution matrix X.
111*> \endverbatim
112*>
113*> \param[in] LDB
114*> \verbatim
115*> LDB is INTEGER
116*> The leading dimension of the array B. LDB >= max(1,N).
117*> \endverbatim
118*>
119*> \param[out] INFO
120*> \verbatim
121*> INFO is INTEGER
122*> = 0: successful exit
123*> < 0: if INFO = -i, the i-th argument had an illegal value
124*> \endverbatim
125*
126* Authors:
127* ========
128*
129*> \author Univ. of Tennessee
130*> \author Univ. of California Berkeley
131*> \author Univ. of Colorado Denver
132*> \author NAG Ltd.
133*
134*> \ingroup hetrs_aa_2stage
135*
136* =====================================================================
137 SUBROUTINE dsytrs_aa_2stage( UPLO, N, NRHS, A, LDA, TB, LTB,
138 $ IPIV, IPIV2, B, LDB, INFO )
139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144 IMPLICIT NONE
145*
146* .. Scalar Arguments ..
147 CHARACTER UPLO
148 INTEGER N, NRHS, LDA, LTB, LDB, INFO
149* ..
150* .. Array Arguments ..
151 INTEGER IPIV( * ), IPIV2( * )
152 DOUBLE PRECISION A( LDA, * ), TB( * ), B( LDB, * )
153* ..
154*
155* =====================================================================
156*
157 DOUBLE PRECISION ONE
158 parameter( one = 1.0d+0 )
159* ..
160* .. Local Scalars ..
161 INTEGER LDTB, NB
162 LOGICAL UPPER
163* ..
164* .. External Functions ..
165 LOGICAL LSAME
166 EXTERNAL lsame
167* ..
168* .. External Subroutines ..
169 EXTERNAL dgbtrs, dlaswp, dtrsm, xerbla
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC max
173* ..
174* .. Executable Statements ..
175*
176 info = 0
177 upper = lsame( uplo, 'U' )
178 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
179 info = -1
180 ELSE IF( n.LT.0 ) THEN
181 info = -2
182 ELSE IF( nrhs.LT.0 ) THEN
183 info = -3
184 ELSE IF( lda.LT.max( 1, n ) ) THEN
185 info = -5
186 ELSE IF( ltb.LT.( 4*n ) ) THEN
187 info = -7
188 ELSE IF( ldb.LT.max( 1, n ) ) THEN
189 info = -11
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'DSYTRS_AA_2STAGE', -info )
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* Read NB and compute LDTB
202*
203 nb = int( tb( 1 ) )
204 ldtb = ltb/n
205*
206 IF( upper ) THEN
207*
208* Solve A*X = B, where A = U**T*T*U.
209*
210 IF( n.GT.nb ) THEN
211*
212* Pivot, P**T * B -> B
213*
214 CALL dlaswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
215*
216* Compute (U**T \ B) -> B [ (U**T \P**T * B) ]
217*
218 CALL dtrsm( 'L', 'U', 'T', 'U', n-nb, nrhs, one, a(1, nb+1),
219 $ lda, b(nb+1, 1), ldb)
220*
221 END IF
222*
223* Compute T \ B -> B [ T \ (U**T \P**T * B) ]
224*
225 CALL dgbtrs( 'N', n, nb, nb, nrhs, tb, ldtb, ipiv2, b, ldb,
226 $ info)
227 IF( n.GT.nb ) THEN
228*
229* Compute (U \ B) -> B [ U \ (T \ (U**T \P**T * B) ) ]
230*
231 CALL dtrsm( 'L', 'U', 'N', 'U', n-nb, nrhs, one, a(1, nb+1),
232 $ lda, b(nb+1, 1), ldb)
233*
234* Pivot, P * B -> B [ P * (U \ (T \ (U**T \P**T * B) )) ]
235*
236 CALL dlaswp( nrhs, b, ldb, nb+1, n, ipiv, -1 )
237*
238 END IF
239*
240 ELSE
241*
242* Solve A*X = B, where A = L*T*L**T.
243*
244 IF( n.GT.nb ) THEN
245*
246* Pivot, P**T * B -> B
247*
248 CALL dlaswp( nrhs, b, ldb, nb+1, n, ipiv, 1 )
249*
250* Compute (L \ B) -> B [ (L \P**T * B) ]
251*
252 CALL dtrsm( 'L', 'L', 'N', 'U', n-nb, nrhs, one, a(nb+1, 1),
253 $ lda, b(nb+1, 1), ldb)
254*
255 END IF
256*
257* Compute T \ B -> B [ T \ (L \P**T * B) ]
258*
259 CALL dgbtrs( 'N', n, nb, nb, nrhs, tb, ldtb, ipiv2, b, ldb,
260 $ info)
261 IF( n.GT.nb ) THEN
262*
263* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
264*
265 CALL dtrsm( 'L', 'L', 'T', 'U', n-nb, nrhs, one, a(nb+1, 1),
266 $ lda, b(nb+1, 1), ldb)
267*
268* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ]
269*
270 CALL dlaswp( nrhs, b, ldb, nb+1, n, ipiv, -1 )
271*
272 END IF
273 END IF
274*
275 RETURN
276*
277* End of DSYTRS_AA_2STAGE
278*
279 END
subroutine xerbla(srname, info)
Definition cblat2.f:3285
subroutine dgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
DGBTRS
Definition dgbtrs.f:138
subroutine dsytrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
DSYTRS_AA_2STAGE
subroutine dlaswp(n, a, lda, k1, k2, ipiv, incx)
DLASWP performs a series of row interchanges on a general rectangular matrix.
Definition dlaswp.f:115
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181