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

◆ chetrs2()

subroutine chetrs2 ( character  uplo,
integer  n,
integer  nrhs,
complex, dimension( lda, * )  a,
integer  lda,
integer, dimension( * )  ipiv,
complex, dimension( ldb, * )  b,
integer  ldb,
complex, dimension( * )  work,
integer  info 
)

CHETRS2

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

Purpose:
 CHETRS2 solves a system of linear equations A*X = B with a complex
 Hermitian matrix A using the factorization A = U*D*U**H or
 A = L*D*L**H computed by CHETRF and converted by CSYCONV.
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*D*U**H;
          = 'L':  Lower triangular, form is A = L*D*L**H.
[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 array, dimension (LDA,N)
          The block diagonal matrix D and the multipliers used to
          obtain the factor U or L as computed by CHETRF.
[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 and the block structure of D
          as determined by CHETRF.
[in,out]B
          B is COMPLEX 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 array, dimension (N)
[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 125 of file chetrs2.f.

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*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
cswap
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81
csyconv
subroutine csyconv(uplo, way, n, a, lda, ipiv, e, info)
CSYCONV
Definition csyconv.f:114
ctrsm
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180
Here is the call graph for this function:
Here is the caller graph for this function: