NAME
SYNOPSIS
- SUBROUTINE CLAQR3(
-
WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )
- INTEGER
-
IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, LDZ, LWORK, N, ND, NH, NS, NV, NW
- LOGICAL
-
WANTT, WANTZ
- COMPLEX
-
H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), WORK( * ), WV( LDWV, * ), Z( LDZ, * )
- COMPLEX
-
ZERO, ONE
- PARAMETER
-
( ZERO = ( 0.0e0, 0.0e0 ), ONE = ( 1.0e0, 0.0e0 ) )
- REAL
-
RZERO, RONE
- PARAMETER
-
( RZERO = 0.0e0, RONE = 1.0e0 )
- COMPLEX
-
BETA, CDUM, S, TAU
- REAL
-
FOO, SAFMAX, SAFMIN, SMLNUM, ULP
- INTEGER
-
I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, LWKOPT, NMIN
- REAL
-
SLAMCH
- INTEGER
-
ILAENV
- EXTERNAL
-
SLAMCH, ILAENV
- EXTERNAL
-
CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLAQR4, CLARF, CLARFG, CLASET, CTREXC, CUNMHR, SLABAD
- INTRINSIC
-
ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL
- REAL
-
CABS1
- CABS1(
-
CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
- JW
-
= MIN( NW, KBOT-KTOP+1 )
- IF(
-
JW.LE.2 ) THEN
- LWKOPT
-
= 1
- ELSE
- CALL
-
CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
- LWK1
-
= INT( WORK( 1 ) )
- CALL
-
CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, WORK, -1, INFO )
- LWK2
-
= INT( WORK( 1 ) )
- CALL
-
CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, LDV, WORK, -1, INFQR )
- LWK3
-
= INT( WORK( 1 ) )
- LWKOPT
-
= MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
- END
-
IF
- IF(
-
LWORK.EQ.-1 ) THEN
- WORK(
-
1 ) = CMPLX( LWKOPT, 0 )
- RETURN
- END
-
IF
- NS
-
= 0
- ND
-
= 0
- WORK(
-
1 ) = ONE
- IF(
-
KTOP.GT.KBOT ) RETURN
- IF(
-
NW.LT.1 ) RETURN
- SAFMIN
-
= SLAMCH( 'SAFE MINIMUM' )
- SAFMAX
-
= RONE / SAFMIN
- CALL
-
SLABAD( SAFMIN, SAFMAX )
- ULP
-
= SLAMCH( 'PRECISION' )
- SMLNUM
-
= SAFMIN*( REAL( N ) / ULP )
- JW
-
= MIN( NW, KBOT-KTOP+1 )
- KWTOP
-
= KBOT - JW + 1
- IF(
-
KWTOP.EQ.KTOP ) THEN
- S
-
= ZERO
- ELSE
- S
-
= H( KWTOP, KWTOP-1 )
- END
-
IF
- IF(
-
KBOT.EQ.KWTOP ) THEN
- SH(
-
KWTOP ) = H( KWTOP, KWTOP )
- NS
-
= 1
- ND
-
= 0
- IF(
-
CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, KWTOP ) ) ) ) THEN
- NS
-
= 0
- ND
-
= 1
- IF(
-
KWTOP.GT.KTOP ) H( KWTOP, KWTOP-1 ) = ZERO
- END
-
IF
- WORK(
-
1 ) = ONE
- RETURN
- END
-
IF
- CALL
-
CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
- CALL
-
CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
- CALL
-
CLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
- NMIN
-
= ILAENV( 12, 'CLAQR3', 'SV', JW, 1, JW, LWORK )
- IF(
-
JW.GT.NMIN ) THEN
- CALL
-
CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR )
- ELSE
- CALL
-
CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, JW, V, LDV, INFQR )
- END
-
IF
- NS
-
= JW
- ILST
-
= INFQR + 1
- DO
-
10 KNT = INFQR + 1, JW
- FOO
-
= CABS1( T( NS, NS ) )
- IF(
-
FOO.EQ.RZERO ) FOO = CABS1( S )
- IF(
-
CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
- NS
-
= NS - 1
- ELSE
- IFST
-
= NS
- CALL
-
CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
- ILST
-
= ILST + 1
- END
-
IF
- 10
-
CONTINUE
- IF(
-
NS.EQ.0 ) S = ZERO
- IF(
-
NS.LT.JW ) THEN
- DO
-
30 I = INFQR + 1, NS
- IFST
-
= I
- DO
-
20 J = I + 1, NS
- IF(
-
CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) IFST = J
- 20
-
CONTINUE
- ILST
-
= I
- IF(
-
IFST.NE.ILST ) CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
- 30
-
CONTINUE
- END
-
IF
- DO
-
40 I = INFQR + 1, JW
- SH(
-
KWTOP+I-1 ) = T( I, I )
- 40
-
CONTINUE
- IF(
-
NS.LT.JW .OR. S.EQ.ZERO ) THEN
- IF(
-
NS.GT.1 .AND. S.NE.ZERO ) THEN
- CALL
-
CCOPY( NS, V, LDV, WORK, 1 )
- DO
-
50 I = 1, NS
- WORK(
-
I ) = CONJG( WORK( I ) )
- 50
-
CONTINUE
- BETA
-
= WORK( 1 )
- CALL
-
CLARFG( NS, BETA, WORK( 2 ), 1, TAU )
- WORK(
-
1 ) = ONE
- CALL
-
CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
- CALL
-
CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, WORK( JW+1 ) )
- CALL
-
CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, WORK( JW+1 ) )
- CALL
-
CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, WORK( JW+1 ) )
- CALL
-
CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), LWORK-JW, INFO )
- END
-
IF
- IF(
-
KWTOP.GT.1 ) H( KWTOP, KWTOP-1 ) = S*CONJG( V( 1, 1 ) )
- CALL
-
CLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
- CALL
-
CCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), LDH+1 )
- IF(
-
NS.GT.1 .AND. S.NE.ZERO ) CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, WORK( JW+1 ), LWORK-JW, INFO )
- IF(
-
WANTT ) THEN
- LTOP
-
= 1
- ELSE
- LTOP
-
= KTOP
- END
-
IF
- DO
-
60 KROW = LTOP, KWTOP - 1, NV
- KLN
-
= MIN( NV, KWTOP-KROW )
- CALL
-
CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), LDH, V, LDV, ZERO, WV, LDWV )
- CALL
-
CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
- 60
-
CONTINUE
- IF(
-
WANTT ) THEN
- DO
-
70 KCOL = KBOT + 1, N, NH
- KLN
-
= MIN( NH, N-KCOL+1 )
- CALL
-
CGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
- CALL
-
CLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), LDH )
- 70
-
CONTINUE
- END
-
IF
- IF(
-
WANTZ ) THEN
- DO
-
80 KROW = ILOZ, IHIZ, NV
- KLN
-
= MIN( NV, IHIZ-KROW+1 )
- CALL
-
CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), LDZ, V, LDV, ZERO, WV, LDWV )
- CALL
-
CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), LDZ )
- 80
-
CONTINUE
- END
-
IF
- END
-
IF
- ND
-
= JW - NS
- NS
-
= NS - INFQR
- WORK(
-
1 ) = CMPLX( LWKOPT, 0 )
- END