LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
chetrs2.f
Go to the documentation of this file.
1*> \brief \b CHETRS2
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download CHETRS2 + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrs2.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrs2.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrs2.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
22* WORK, INFO )
23*
24* .. Scalar Arguments ..
25* CHARACTER UPLO
26* INTEGER INFO, LDA, LDB, N, NRHS
27* ..
28* .. Array Arguments ..
29* INTEGER IPIV( * )
30* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
31* ..
32*
33*
34*> \par Purpose:
35* =============
36*>
37*> \verbatim
38*>
39*> CHETRS2 solves a system of linear equations A*X = B with a complex
40*> Hermitian matrix A using the factorization A = U*D*U**H or
41*> A = L*D*L**H computed by CHETRF and converted by CSYCONV.
42*> \endverbatim
43*
44* Arguments:
45* ==========
46*
47*> \param[in] UPLO
48*> \verbatim
49*> UPLO is CHARACTER*1
50*> Specifies whether the details of the factorization are stored
51*> as an upper or lower triangular matrix.
52*> = 'U': Upper triangular, form is A = U*D*U**H;
53*> = 'L': Lower triangular, form is A = L*D*L**H.
54*> \endverbatim
55*>
56*> \param[in] N
57*> \verbatim
58*> N is INTEGER
59*> The order of the matrix A. N >= 0.
60*> \endverbatim
61*>
62*> \param[in] NRHS
63*> \verbatim
64*> NRHS is INTEGER
65*> The number of right hand sides, i.e., the number of columns
66*> of the matrix B. NRHS >= 0.
67*> \endverbatim
68*>
69*> \param[in] A
70*> \verbatim
71*> A is COMPLEX array, dimension (LDA,N)
72*> The block diagonal matrix D and the multipliers used to
73*> obtain the factor U or L as computed by CHETRF.
74*> \endverbatim
75*>
76*> \param[in] LDA
77*> \verbatim
78*> LDA is INTEGER
79*> The leading dimension of the array A. LDA >= max(1,N).
80*> \endverbatim
81*>
82*> \param[in] IPIV
83*> \verbatim
84*> IPIV is INTEGER array, dimension (N)
85*> Details of the interchanges and the block structure of D
86*> as determined by CHETRF.
87*> \endverbatim
88*>
89*> \param[in,out] B
90*> \verbatim
91*> B is COMPLEX array, dimension (LDB,NRHS)
92*> On entry, the right hand side matrix B.
93*> On exit, the solution matrix X.
94*> \endverbatim
95*>
96*> \param[in] LDB
97*> \verbatim
98*> LDB is INTEGER
99*> The leading dimension of the array B. LDB >= max(1,N).
100*> \endverbatim
101*>
102*> \param[out] WORK
103*> \verbatim
104*> WORK is COMPLEX array, dimension (N)
105*> \endverbatim
106*>
107*> \param[out] INFO
108*> \verbatim
109*> INFO is INTEGER
110*> = 0: successful exit
111*> < 0: if INFO = -i, the i-th argument had an illegal value
112*> \endverbatim
113*
114* Authors:
115* ========
116*
117*> \author Univ. of Tennessee
118*> \author Univ. of California Berkeley
119*> \author Univ. of Colorado Denver
120*> \author NAG Ltd.
121*
122*> \ingroup hetrs2
123*
124* =====================================================================
125 SUBROUTINE chetrs2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
126 $ WORK, INFO )
127*
128* -- LAPACK computational routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 CHARACTER UPLO
134 INTEGER INFO, LDA, LDB, N, NRHS
135* ..
136* .. Array Arguments ..
137 INTEGER IPIV( * )
138 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 COMPLEX ONE
145 parameter( one = (1.0e+0,0.0e+0) )
146* ..
147* .. Local Scalars ..
148 LOGICAL UPPER
149 INTEGER I, IINFO, J, K, KP
150 REAL S
151 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 EXTERNAL lsame
156* ..
157* .. External Subroutines ..
158 EXTERNAL csscal, csyconv, cswap, ctrsm, xerbla
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC conjg, max, real
162* ..
163* .. Executable Statements ..
164*
165 info = 0
166 upper = lsame( uplo, 'U' )
167 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
168 info = -1
169 ELSE IF( n.LT.0 ) THEN
170 info = -2
171 ELSE IF( nrhs.LT.0 ) THEN
172 info = -3
173 ELSE IF( lda.LT.max( 1, n ) ) THEN
174 info = -5
175 ELSE IF( ldb.LT.max( 1, n ) ) THEN
176 info = -8
177 END IF
178 IF( info.NE.0 ) THEN
179 CALL xerbla( 'CHETRS2', -info )
180 RETURN
181 END IF
182*
183* Quick return if possible
184*
185 IF( n.EQ.0 .OR. nrhs.EQ.0 )
186 $ RETURN
187*
188* Convert A
189*
190 CALL csyconv( uplo, 'C', n, a, lda, ipiv, work, iinfo )
191*
192 IF( upper ) THEN
193*
194* Solve A*X = B, where A = U*D*U**H.
195*
196* P**T * B
197 k=n
198 DO WHILE ( k .GE. 1 )
199 IF( ipiv( k ).GT.0 ) THEN
200* 1 x 1 diagonal block
201* Interchange rows K and IPIV(K).
202 kp = ipiv( k )
203 IF( kp.NE.k )
204 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
205 k=k-1
206 ELSE
207* 2 x 2 diagonal block
208* Interchange rows K-1 and -IPIV(K).
209 kp = -ipiv( k )
210 IF( kp.EQ.-ipiv( k-1 ) )
211 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
212 k=k-2
213 END IF
214 END DO
215*
216* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
217*
218 CALL ctrsm('L','U','N','U',n,nrhs,one,a,lda,b,ldb)
219*
220* Compute D \ B -> B [ D \ (U \P**T * B) ]
221*
222 i=n
223 DO WHILE ( i .GE. 1 )
224 IF( ipiv(i) .GT. 0 ) THEN
225 s = real( one ) / real( a( i, i ) )
226 CALL csscal( nrhs, s, b( i, 1 ), ldb )
227 ELSEIF ( i .GT. 1) THEN
228 IF ( ipiv(i-1) .EQ. ipiv(i) ) THEN
229 akm1k = work(i)
230 akm1 = a( i-1, i-1 ) / akm1k
231 ak = a( i, i ) / conjg( akm1k )
232 denom = akm1*ak - one
233 DO 15 j = 1, nrhs
234 bkm1 = b( i-1, j ) / akm1k
235 bk = b( i, j ) / conjg( akm1k )
236 b( i-1, j ) = ( ak*bkm1-bk ) / denom
237 b( i, j ) = ( akm1*bk-bkm1 ) / denom
238 15 CONTINUE
239 i = i - 1
240 ENDIF
241 ENDIF
242 i = i - 1
243 END DO
244*
245* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ]
246*
247 CALL ctrsm('L','U','C','U',n,nrhs,one,a,lda,b,ldb)
248*
249* P * B [ P * (U**H \ (D \ (U \P**T * B) )) ]
250*
251 k=1
252 DO WHILE ( k .LE. n )
253 IF( ipiv( k ).GT.0 ) THEN
254* 1 x 1 diagonal block
255* Interchange rows K and IPIV(K).
256 kp = ipiv( k )
257 IF( kp.NE.k )
258 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
259 k=k+1
260 ELSE
261* 2 x 2 diagonal block
262* Interchange rows K-1 and -IPIV(K).
263 kp = -ipiv( k )
264 IF( k .LT. n .AND. kp.EQ.-ipiv( k+1 ) )
265 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
266 k=k+2
267 ENDIF
268 END DO
269*
270 ELSE
271*
272* Solve A*X = B, where A = L*D*L**H.
273*
274* P**T * B
275 k=1
276 DO WHILE ( k .LE. n )
277 IF( ipiv( k ).GT.0 ) THEN
278* 1 x 1 diagonal block
279* Interchange rows K and IPIV(K).
280 kp = ipiv( k )
281 IF( kp.NE.k )
282 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
283 k=k+1
284 ELSE
285* 2 x 2 diagonal block
286* Interchange rows K and -IPIV(K+1).
287 kp = -ipiv( k+1 )
288 IF( kp.EQ.-ipiv( k ) )
289 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
290 k=k+2
291 ENDIF
292 END DO
293*
294* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
295*
296 CALL ctrsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb)
297*
298* Compute D \ B -> B [ D \ (L \P**T * B) ]
299*
300 i=1
301 DO WHILE ( i .LE. n )
302 IF( ipiv(i) .GT. 0 ) THEN
303 s = real( one ) / real( a( i, i ) )
304 CALL csscal( nrhs, s, b( i, 1 ), ldb )
305 ELSE
306 akm1k = work(i)
307 akm1 = a( i, i ) / conjg( akm1k )
308 ak = a( i+1, i+1 ) / akm1k
309 denom = akm1*ak - one
310 DO 25 j = 1, nrhs
311 bkm1 = b( i, j ) / conjg( akm1k )
312 bk = b( i+1, j ) / akm1k
313 b( i, j ) = ( ak*bkm1-bk ) / denom
314 b( i+1, j ) = ( akm1*bk-bkm1 ) / denom
315 25 CONTINUE
316 i = i + 1
317 ENDIF
318 i = i + 1
319 END DO
320*
321* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ]
322*
323 CALL ctrsm('L','L','C','U',n,nrhs,one,a,lda,b,ldb)
324*
325* P * B [ P * (L**H \ (D \ (L \P**T * B) )) ]
326*
327 k=n
328 DO WHILE ( k .GE. 1 )
329 IF( ipiv( k ).GT.0 ) THEN
330* 1 x 1 diagonal block
331* Interchange rows K and IPIV(K).
332 kp = ipiv( k )
333 IF( kp.NE.k )
334 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
335 k=k-1
336 ELSE
337* 2 x 2 diagonal block
338* Interchange rows K-1 and -IPIV(K).
339 kp = -ipiv( k )
340 IF( k.GT.1 .AND. kp.EQ.-ipiv( k-1 ) )
341 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
342 k=k-2
343 ENDIF
344 END DO
345*
346 END IF
347*
348* Revert A
349*
350 CALL csyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo )
351*
352 RETURN
353*
354* End of CHETRS2
355*
356 END
subroutine xerbla(srname, info)
Definition cblat2.f:3285
subroutine chetrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
CHETRS2
Definition chetrs2.f:127
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81
subroutine csyconv(uplo, way, n, a, lda, ipiv, e, info)
CSYCONV
Definition csyconv.f:114
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180