---
name: "zlaqr2"
section: "3lapack"
platform: "linux"
package: "liblapack-doc"
version: "3.2.1-8"
release: "Debian 6.0 (Squeeze)"
platforms: ["linux"]
url: "https://new.carta.tech/zlaqr2/3lapack"
---

# zlaqr2(3lapack)

## 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( '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 ) = 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( 'SAFE MINIMUM' )

- SAFMAX

  \= RONE / SAFMIN

- CALL

  DLABAD( SAFMIN, SAFMAX )

- ULP

  \= DLAMCH( 'PRECISION' )

- 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( 'U', 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( 'A', 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( '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 ZTREXC( '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

  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( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )

- CALL

  ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, WORK( JW+1 ) )

- CALL

  ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, WORK( JW+1 ) )

- CALL

  ZLARF( 'R', 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( 'U', 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( '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

  ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), LDH, V, LDV, ZERO, WV, LDWV )

- CALL

  ZLACPY( '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

  ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, H( KWTOP, KCOL ), LDH, ZERO, T, LDT )

- CALL

  ZLACPY( '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

  ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), LDZ, V, LDV, ZERO, WV, LDWV )

- CALL

  ZLACPY( 'A', 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