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