215 parameter( zero = 0.0e+0, one = 1.0e+0 )
217 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
219 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
223 INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
225 REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
226 COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
232 EXTERNAL lsame, icamax, slamch
238 INTRINSIC abs, max, sqrt, aimag, real
244 cabs1( z ) = abs(
REAL( Z ) ) + abs( AIMAG( z ) )
251 upper = lsame( uplo,
'U' )
252 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
254 ELSE IF( n.LT.0 )
THEN
256 ELSE IF( lda.LT.max( 1, n ) )
THEN
260 CALL
xerbla(
'CSYTF2_ROOK', -info )
266 alpha = ( one+sqrt( sevten ) ) / eight
270 sfmin = slamch(
'S' )
292 absakk = cabs1( a( k, k ) )
299 imax = icamax( k-1, a( 1, k ), 1 )
300 colmax = cabs1( a( imax, k ) )
305 IF( (max( absakk, colmax ).EQ.zero) )
THEN
319 IF( .NOT.( absakk.LT.alpha*colmax ) )
THEN
340 jmax = imax + icamax( k-imax, a( imax, imax+1 ),
342 rowmax = cabs1( a( imax, jmax ) )
348 itemp = icamax( imax-1, a( 1, imax ), 1 )
349 stemp = cabs1( a( itemp, imax ) )
350 IF( stemp.GT.rowmax )
THEN
359 IF( .NOT.( cabs1(a( imax, imax )).LT.alpha*rowmax ) )
371 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) )
THEN
390 IF( .NOT. done ) goto 12
398 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) )
THEN
404 $ CALL
cswap( p-1, a( 1, k ), 1, a( 1, p ), 1 )
406 $ CALL
cswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),
409 a( k, k ) = a( p, p )
422 $ CALL
cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
423 IF( ( kk.GT.1 ) .AND. ( kp.LT.(kk-1) ) )
424 $ CALL
cswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),
427 a( kk, kk ) = a( kp, kp )
429 IF( kstep.EQ.2 )
THEN
431 a( k-1, k ) = a( kp, k )
438 IF( kstep.EQ.1 )
THEN
451 IF( cabs1( a( k, k ) ).GE.sfmin )
THEN
457 d11 = cone / a( k, k )
458 CALL
csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
462 CALL
cscal( k-1, d11, a( 1, k ), 1 )
469 a( ii, k ) = a( ii, k ) / d11
477 CALL
csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
500 d22 = a( k-1, k-1 ) / d12
501 d11 = a( k, k ) / d12
502 t = cone / ( d11*d22-cone )
504 DO 30 j = k - 2, 1, -1
506 wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
507 wk = t*( d22*a( j, k )-a( j, k-1 ) )
510 a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -
511 $ ( a( i, k-1 ) / d12 )*wkm1
517 a( j, k-1 ) = wkm1 / d12
528 IF( kstep.EQ.1 )
THEN
560 absakk = cabs1( a( k, k ) )
567 imax = k + icamax( n-k, a( k+1, k ), 1 )
568 colmax = cabs1( a( imax, k ) )
573 IF( ( max( absakk, colmax ).EQ.zero ) )
THEN
587 IF( .NOT.( absakk.LT.alpha*colmax ) )
THEN
607 jmax = k - 1 + icamax( imax-k, a( imax, k ), lda )
608 rowmax = cabs1( a( imax, jmax ) )
614 itemp = imax + icamax( n-imax, a( imax+1, imax ),
616 stemp = cabs1( a( itemp, imax ) )
617 IF( stemp.GT.rowmax )
THEN
626 IF( .NOT.( cabs1(a( imax, imax )).LT.alpha*rowmax ) )
638 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) )
THEN
657 IF( .NOT. done ) goto 42
665 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) )
THEN
671 $ CALL
cswap( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
673 $ CALL
cswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda )
675 a( k, k ) = a( p, p )
688 $ CALL
cswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
689 IF( ( kk.LT.n ) .AND. ( kp.GT.(kk+1) ) )
690 $ CALL
cswap( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
693 a( kk, kk ) = a( kp, kp )
695 IF( kstep.EQ.2 )
THEN
697 a( k+1, k ) = a( kp, k )
704 IF( kstep.EQ.1 )
THEN
717 IF( cabs1( a( k, k ) ).GE.sfmin )
THEN
723 d11 = cone / a( k, k )
724 CALL
csyr( uplo, n-k, -d11, a( k+1, k ), 1,
725 $ a( k+1, k+1 ), lda )
729 CALL
cscal( n-k, d11, a( k+1, k ), 1 )
736 a( ii, k ) = a( ii, k ) / d11
744 CALL
csyr( uplo, n-k, -d11, a( k+1, k ), 1,
745 $ a( k+1, k+1 ), lda )
769 d11 = a( k+1, k+1 ) / d21
770 d22 = a( k, k ) / d21
771 t = cone / ( d11*d22-cone )
777 wk = t*( d11*a( j, k )-a( j, k+1 ) )
778 wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
783 a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -
784 $ ( a( i, k+1 ) / d21 )*wkp1
790 a( j, k+1 ) = wkp1 / d21
801 IF( kstep.EQ.1 )
THEN
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine csyr(UPLO, N, ALPHA, X, INCX, A, LDA)
CSYR performs the symmetric rank-1 update of a complex symmetric matrix.
subroutine csytf2_rook(UPLO, N, A, LDA, IPIV, INFO)
CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bun...