t man page on Scientific
[printable version]
ZLAQR3(1) LAPACK auxiliary routine (version 3.2) ZLAQR3(1)
NAME
SYNOPSIS
SUBROUTINE ZLAQR3( 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, LWK3, LWKOPT, NMIN
DOUBLE PRECISION DLAMCH
INTEGER ILAENV
EXTERNAL DLAMCH, ILAENV
EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
ZLAQR4, 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 ) )
CALL ZLAQR4( .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 ) = 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 )
NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK )
IF( JW.GT.NMIN ) THEN
CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP
), 1, JW, V, LDV, WORK, LWORK, INFQR )
ELSE
CALL ZLAHQR( .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 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
LAPACK auxiliary routine (versioNovember 2008 ZLAQR3(1)
[top]
List of man pages available for Scientific
Copyright (c) for man pages and the logo by the respective OS vendor.
For those who want to learn more, the polarhome community provides shell access and support.
[legal]
[privacy]
[GNU]
[policy]
[cookies]
[netiquette]
[sponsors]
[FAQ]
Polarhome, production since 1999.
Member of Polarhome portal.
Based on Fawad Halim's script.
....................................................................
|
Vote for polarhome
|