claqr2(l) - Linux man page
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( '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 ) = 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 )
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( '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