SYNOPSIS¶
- SUBROUTINE
CLAQR2(
- 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, LWKOPT REAL
SLAMCH EXTERNAL SLAMCH EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, 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 ) ) LWKOPT = JW + MAX( LWK1, LWK2 ) 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 ) CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, JW, V,
LDV, INFQR ) 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