claqr2 (l) - Linux Manuals

NAME

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( aqRaq, aqNaq, 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( aqSAFE MINIMUMaq )

    
SAFMAX = RONE / SAFMIN

    
CALL SLABAD( SAFMIN, SAFMAX )

    
ULP = SLAMCH( aqPRECISIONaq )

    
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( aqUaq, 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( aqAaq, 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( aqVaq, 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( aqVaq, 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( aqLaq, JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )

    
CALL CLARF( aqLaq, NS, JW, WORK, 1, CONJG( TAU ), T, LDT, WORK( JW+1 ) )

    
CALL CLARF( aqRaq, NS, NS, WORK, 1, TAU, T, LDT, WORK( JW+1 ) )

    
CALL CLARF( aqRaq, 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( aqUaq, 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( aqRaq, aqNaq, 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( aqNaq, aqNaq, KLN, JW, JW, ONE, H( KROW, KWTOP ), LDH, V, LDV, ZERO, WV, LDWV )

    
CALL CLACPY( aqAaq, 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( aqCaq, aqNaq, JW, KLN, JW, ONE, V, LDV, H( KWTOP, KCOL ), LDH, ZERO, T, LDT )

    
CALL CLACPY( aqAaq, 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( aqNaq, aqNaq, KLN, JW, JW, ONE, Z( KROW, KWTOP ), LDZ, V, LDV, ZERO, WV, LDWV )

    
CALL CLACPY( aqAaq, 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

PURPOSE