LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ zhetrs_aa()

subroutine zhetrs_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 
)

ZHETRS_AA

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

Purpose:
 ZHETRS_AA solves a system of linear equations A*X = B with a complex
 hermitian matrix A using the factorization A = U**H*T*U or
 A = L*T*L**H computed by ZHETRF_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**H*T*U;
          = 'L':  Lower triangular, form is A = L*T*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*16 array, dimension (LDA,N)
          Details of factors computed by ZHETRF_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 ZHETRF_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 130 of file zhetrs_aa.f.

132 *
133 * -- LAPACK computational routine --
134 * -- LAPACK is a software package provided by Univ. of Tennessee, --
135 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136 *
137  IMPLICIT NONE
138 *
139 * .. Scalar Arguments ..
140  CHARACTER UPLO
141  INTEGER N, NRHS, LDA, LDB, LWORK, INFO
142 * ..
143 * .. Array Arguments ..
144  INTEGER IPIV( * )
145  COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
146 * ..
147 *
148 * =====================================================================
149 *
150  COMPLEX*16 ONE
151  parameter( one = 1.0d+0 )
152 * ..
153 * .. Local Scalars ..
154  LOGICAL LQUERY, UPPER
155  INTEGER K, KP, LWKOPT
156 * ..
157 * .. External Functions ..
158  LOGICAL LSAME
159  EXTERNAL lsame
160 * ..
161 * .. External Subroutines ..
162  EXTERNAL zgtsv, zswap, ztrsm, zlacgv, zlacpy, xerbla
163 * ..
164 * .. Intrinsic Functions ..
165  INTRINSIC max
166 * ..
167 * .. Executable Statements ..
168 *
169  info = 0
170  upper = lsame( uplo, 'U' )
171  lquery = ( lwork.EQ.-1 )
172  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
173  info = -1
174  ELSE IF( n.LT.0 ) THEN
175  info = -2
176  ELSE IF( nrhs.LT.0 ) THEN
177  info = -3
178  ELSE IF( lda.LT.max( 1, n ) ) THEN
179  info = -5
180  ELSE IF( ldb.LT.max( 1, n ) ) THEN
181  info = -8
182  ELSE IF( lwork.LT.max( 1, 3*n-2 ) .AND. .NOT.lquery ) THEN
183  info = -10
184  END IF
185  IF( info.NE.0 ) THEN
186  CALL xerbla( 'ZHETRS_AA', -info )
187  RETURN
188  ELSE IF( lquery ) THEN
189  lwkopt = (3*n-2)
190  work( 1 ) = lwkopt
191  RETURN
192  END IF
193 *
194 * Quick return if possible
195 *
196  IF( n.EQ.0 .OR. nrhs.EQ.0 )
197  $ RETURN
198 *
199  IF( upper ) THEN
200 *
201 * Solve A*X = B, where A = U**H*T*U.
202 *
203 * 1) Forward substitution with U**H
204 *
205  IF( n.GT.1 ) THEN
206 *
207 * Pivot, P**T * B -> B
208 *
209  DO k = 1, n
210  kp = ipiv( k )
211  IF( kp.NE.k )
212  $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
213  END DO
214 *
215 * Compute U**H \ B -> B [ (U**H \P**T * B) ]
216 *
217  CALL ztrsm( 'L', 'U', 'C', 'U', n-1, nrhs, one, a( 1, 2 ),
218  $ lda, b( 2, 1 ), ldb )
219  END IF
220 *
221 * 2) Solve with triangular matrix T
222 *
223 * Compute T \ B -> B [ T \ (U**H \P**T * B) ]
224 *
225  CALL zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1 )
226  IF( n.GT.1 ) THEN
227  CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1)
228  CALL zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 )
229  CALL zlacgv( n-1, work( 1 ), 1 )
230  END IF
231  CALL zgtsv( n, nrhs, work(1), work(n), work(2*n), b, 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**H \P**T * B) ) ]
239 *
240  CALL ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),
241  $ lda, b(2, 1), ldb)
242 *
243 * Pivot, P * B [ P * (U**H \ (T \ (U \P**T * B) )) ]
244 *
245  DO k = n, 1, -1
246  kp = ipiv( k )
247  IF( kp.NE.k )
248  $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
249  END DO
250  END IF
251 *
252  ELSE
253 *
254 * Solve A*X = B, where A = L*T*L**H.
255 *
256 * 1) Forward substitution with L
257 *
258  IF( n.GT.1 ) THEN
259 *
260 * Pivot, P**T * B -> B
261 *
262  DO k = 1, n
263  kp = ipiv( k )
264  IF( kp.NE.k )
265  $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
266  END DO
267 *
268 * Compute L \ B -> B [ (L \P**T * B) ]
269 *
270  CALL ztrsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1 ),
271  $ lda, b(2, 1), ldb)
272  END IF
273 *
274 * 2) Solve with triangular matrix T
275 *
276 * Compute T \ B -> B [ T \ (L \P**T * B) ]
277 *
278  CALL zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1)
279  IF( n.GT.1 ) THEN
280  CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1)
281  CALL zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1)
282  CALL zlacgv( n-1, work( 2*n ), 1 )
283  END IF
284  CALL zgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,
285  $ info)
286 *
287 * 3) Backward substitution with L**H
288 *
289  IF( n.GT.1 ) THEN
290 *
291 * Compute L**H \ B -> B [ L**H \ (T \ (L \P**T * B) ) ]
292 *
293  CALL ztrsm( 'L', 'L', 'C', 'U', n-1, nrhs, one, a( 2, 1 ),
294  $ lda, b( 2, 1 ), ldb)
295 *
296 * Pivot, P * B [ P * (L**H \ (T \ (L \P**T * B) )) ]
297 *
298  DO k = n, 1, -1
299  kp = ipiv( k )
300  IF( kp.NE.k )
301  $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
302  END DO
303  END IF
304 *
305  END IF
306 *
307  RETURN
308 *
309 * End of ZHETRS_AA
310 *
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
Definition: zswap.f:81
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
Definition: ztrsm.f:180
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:124
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:103
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
Definition: zlacgv.f:74
Here is the call graph for this function:
Here is the caller graph for this function: