137 SUBROUTINE chetrf_aa( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
148 INTEGER N, LDA, LWORK, INFO
152 COMPLEX A( lda, * ), WORK( * )
158 parameter ( zero = (0.0e+0, 0.0e+0), one = (1.0e+0, 0.0e+0) )
161 LOGICAL LQUERY, UPPER
162 INTEGER J, LWKOPT, IINFO
163 INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB
169 EXTERNAL lsame, ilaenv
175 INTRINSIC REAL, CONJG, MAX
181 nb = ilaenv( 1,
'CHETRF', uplo, n, -1, -1, -1 )
186 upper = lsame( uplo,
'U' )
187 lquery = ( lwork.EQ.-1 )
188 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
190 ELSE IF( n.LT.0 )
THEN
192 ELSE IF( lda.LT.max( 1, n ) )
THEN
194 ELSE IF( lwork.LT.( 2*n ) .AND. .NOT.lquery )
THEN
204 CALL xerbla(
'CHETRF_AA', -info )
206 ELSE IF( lquery )
THEN
217 a( 1, 1 ) =
REAL( A( 1, 1 ) )
218 IF ( a( 1, 1 ).EQ.zero )
THEN
226 IF( lwork.LT.((1+nb)*n) )
THEN
238 CALL ccopy( n, a( 1, 1 ), lda, work( 1 ), 1 )
257 jb = min( n-j1+1, nb )
263 $ a( max(1, j), j+1 ), lda,
264 $ ipiv( j+1 ), work, n, work( n*nb+1 ),
266 IF( (iinfo.GT.0) .AND. (info.EQ.0) )
THEN
272 DO j2 = j+2, min(n, j+jb+1)
273 ipiv( j2 ) = ipiv( j2 ) + j
274 IF( (j2.NE.ipiv(j2)) .AND. ((j1-k1).GT.2) )
THEN
275 CALL cswap( j1-k1-2, a( 1, j2 ), 1,
276 $ a( 1, ipiv(j2) ), 1 )
289 IF( j1.GT.1 .OR. jb.GT.1 )
THEN
293 alpha = conjg( a( j, j+1 ) )
295 CALL ccopy( n-j, a( j-1, j+1 ), lda,
296 $ work( (j+1-j1+1)+jb*n ), 1 )
297 CALL cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 )
320 nj = min( nb, n-j2+1 )
326 CALL cgemm(
'Conjugate transpose',
'Transpose',
328 $ -one, a( j1-k2, j3 ), lda,
329 $ work( (j3-j1+1)+k1*n ), n,
330 $ one, a( j3, j3 ), lda )
336 CALL cgemm(
'Conjugate transpose',
'Transpose',
338 $ -one, a( j1-k2, j2 ), lda,
339 $ work( (j3-j1+1)+k1*n ), n,
340 $ one, a( j2, j3 ), lda )
345 a( j, j+1 ) = conjg( alpha )
350 CALL ccopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 )
362 CALL ccopy( n, a( 1, 1 ), 1, work( 1 ), 1 )
381 jb = min( n-j1+1, nb )
387 $ a( j+1, max(1, j) ), lda,
388 $ ipiv( j+1 ), work, n, work( n*nb+1 ), iinfo)
389 IF( (iinfo.GT.0) .AND. (info.EQ.0) )
THEN
395 DO j2 = j+2, min(n, j+jb+1)
396 ipiv( j2 ) = ipiv( j2 ) + j
397 IF( (j2.NE.ipiv(j2)) .AND. ((j1-k1).GT.2) )
THEN
398 CALL cswap( j1-k1-2, a( j2, 1 ), lda,
399 $ a( ipiv(j2), 1 ), lda )
412 IF( j1.GT.1 .OR. jb.GT.1 )
THEN
416 alpha = conjg( a( j+1, j ) )
418 CALL ccopy( n-j, a( j+1, j-1 ), 1,
419 $ work( (j+1-j1+1)+jb*n ), 1 )
420 CALL cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 )
443 nj = min( nb, n-j2+1 )
449 CALL cgemm(
'No transpose',
'Conjugate transpose',
451 $ -one, work( (j3-j1+1)+k1*n ), n,
452 $ a( j3, j1-k2 ), lda,
453 $ one, a( j3, j3 ), lda )
459 CALL cgemm(
'No transpose',
'Conjugate transpose',
461 $ -one, work( (j3-j1+1)+k1*n ), n,
462 $ a( j2, j1-k2 ), lda,
463 $ one, a( j3, j2 ), lda )
468 a( j+1, j ) = conjg( alpha )
473 CALL ccopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 )
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine clahef_aa(UPLO, J1, M, NB, A, LDA, IPIV, H, LDH, WORK, INFO)
CLAHEF_AA
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine chetrf_aa(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CHETRF_AA
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM