zlaqr2 (l) - Linux Manuals

NAME

SYNOPSIS

SUBROUTINE ZLAQR2(
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*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), WORK( * ), WV( LDWV, * ), Z( LDZ, * )

    
COMPLEX*16 ZERO, ONE

    
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), ONE = ( 1.0d0, 0.0d0 ) )

    
DOUBLE PRECISION RZERO, RONE

    
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )

    
COMPLEX*16 BETA, CDUM, S, TAU

    
DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP

    
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT

    
DOUBLE PRECISION DLAMCH

    
EXTERNAL DLAMCH

    
EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR

    
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN

    
DOUBLE PRECISION CABS1

    
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )

    
JW = MIN( NW, KBOT-KTOP+1 )

    
IF( JW.LE.2 ) THEN

    
LWKOPT = 1

    
ELSE

    
CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )

    
LWK1 = INT( WORK( 1 ) )

    
CALL ZUNMHR( 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 ) = DCMPLX( LWKOPT, 0 )

    
RETURN

    
END IF

    
NS = 0

    
ND = 0

    
WORK( 1 ) = ONE

    
IF( KTOP.GT.KBOT ) RETURN

    
IF( NW.LT.1 ) RETURN

    
SAFMIN = DLAMCH( aqSAFE MINIMUMaq )

    
SAFMAX = RONE / SAFMIN

    
CALL DLABAD( SAFMIN, SAFMAX )

    
ULP = DLAMCH( aqPRECISIONaq )

    
SMLNUM = SAFMIN*( DBLE( 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 ZLACPY( aqUaq, JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )

    
CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )

    
CALL ZLASET( aqAaq, JW, JW, ZERO, ONE, V, LDV )

    
CALL ZLAHQR( .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 ZTREXC( 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 ZTREXC( 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 ZCOPY( NS, V, LDV, WORK, 1 )

    
DO 50 I = 1, NS

    
WORK( I ) = DCONJG( WORK( I ) )

    
50 CONTINUE

    
BETA = WORK( 1 )

    
CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )

    
WORK( 1 ) = ONE

    
CALL ZLASET( aqLaq, JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )

    
CALL ZLARF( aqLaq, NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, WORK( JW+1 ) )

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

    
CALL ZLARF( aqRaq, JW, NS, WORK, 1, TAU, V, LDV, WORK( JW+1 ) )

    
CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), LWORK-JW, INFO )

    
END IF

    
IF( KWTOP.GT.1 ) H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )

    
CALL ZLACPY( aqUaq, JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )

    
CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), LDH+1 )

    
IF( NS.GT.1 .AND. S.NE.ZERO ) CALL ZUNMHR( 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 ZGEMM( aqNaq, aqNaq, KLN, JW, JW, ONE, H( KROW, KWTOP ), LDH, V, LDV, ZERO, WV, LDWV )

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

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

    
CALL ZLACPY( aqAaq, KLN, JW, WV, LDWV, Z( KROW, KWTOP ), LDZ )

    
80 CONTINUE

    
END IF

    
END IF

    
ND = JW - NS

    
NS = NS - INFQR

    
WORK( 1 ) = DCMPLX( LWKOPT, 0 )

    
END

PURPOSE