U man page on Scientific
[printable version]
ZLAQR5(1) LAPACK auxiliary routine (version 3.2) ZLAQR5(1)
NAME
SYNOPSIS
SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H,
LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV,
LDWV, NH, WH, LDWH )
INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, LDWH,
LDWV, LDZ, N, NH, NSHFTS, NV
LOGICAL WANTT, WANTZ
COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), WH(
LDWH, * ), 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 ALPHA, BETA, CDUM, REFSUM
DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
SMLNUM, TST1, TST2, ULP
INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, JROW,
JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, M, M22,
MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, NS, NU
LOGICAL ACCUM, BLK22, BMP22
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
COMPLEX*16 VT( 3 )
EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, ZTRMM
DOUBLE PRECISION CABS1
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
IF( NSHFTS.LT.2 ) RETURN
IF( KTOP.GE.KBOT ) RETURN
NS = NSHFTS - MOD( NSHFTS, 2 )
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
IF( KTOP+2.LE.KBOT ) H( KTOP+2, KTOP ) = ZERO
NBMPS = NS / 2
KDU = 6*NBMPS - 3
DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2,
3*NBMPS - 2
NDCOL = INCOL + KDU
IF( ACCUM ) CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U,
LDU )
DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
M22 = MBOT + 1
BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
( KBOT-2 )
DO 10 M = MTOP, MBOT
K = KRCOL + 3*( M-1 )
IF( K.EQ.KTOP-1 ) THEN
CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), S( 2*M
), V( 1, M ) )
ALPHA = V( 1, M )
CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
ELSE
BETA = H( K+1, K )
V( 2, M ) = H( K+2, K )
V( 3, M ) = H( K+3, K )
CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. ZERO
.OR. H( K+3, K+2 ).EQ.ZERO ) THEN
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), S( 2*M ),
VT )
ALPHA = VT( 1 )
CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = DCONJG( VT( 1 ) )* ( H( K+1, K )+DCONJG( VT( 2 )
)* H( K+2, K ) )
IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ CABS1( REF‐
SUM*VT( 3 ) ).GT.ULP* ( CABS1( H( K, K ) )+CABS1( H(
K+1, K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
H( K+1, K ) = H( K+1, K ) - REFSUM
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 )
V( 2, M ) = VT( 2 )
V( 3, M ) = VT( 3 )
END IF
END IF
END IF
10 CONTINUE
K = KRCOL + 3*( M22-1 )
IF( BMP22 ) THEN
IF( K.EQ.KTOP-1 ) THEN
CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), S(
2*M22 ), V( 1, M22 ) )
BETA = V( 1, M22 )
CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
ELSE
BETA = H( K+1, K )
V( 2, M22 ) = H( K+2, K )
CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
END IF
END IF
IF( ACCUM ) THEN
JBOT = MIN( NDCOL, KBOT )
ELSE IF( WANTT ) THEN
JBOT = N
ELSE
JBOT = KBOT
END IF
DO 30 J = MAX( KTOP, KRCOL ), JBOT
MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
DO 20 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = DCONJG( V( 1, M ) )* ( H( K+1, J )+DCONJG( V( 2, M
) )* H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
20 CONTINUE
30 CONTINUE
IF( BMP22 ) THEN
K = KRCOL + 3*( M22-1 )
DO 40 J = MAX( K+1, KTOP ), JBOT
REFSUM = DCONJG( V( 1, M22 ) )* ( H( K+1, J )+DCONJG( V( 2,
M22 ) )* H( K+2, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
40 CONTINUE
END IF
IF( ACCUM ) THEN
JTOP = MAX( KTOP, INCOL )
ELSE IF( WANTT ) THEN
JTOP = 1
ELSE
JTOP = KTOP
END IF
DO 80 M = MTOP, MBOT
IF( V( 1, M ).NE.ZERO ) THEN
K = KRCOL + 3*( M-1 )
DO 50 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* H( J, K+2 )+V(
3, M )*H( J, K+3 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) - REFSUM*DCONJG( V( 2, M ) )
H( J, K+3 ) = H( J, K+3 ) - REFSUM*DCONJG( V( 3, M ) )
50 CONTINUE
IF( ACCUM ) THEN
KMS = K - INCOL
DO 60 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* U( J, KMS+2
)+V( 3, M )*U( J, KMS+3 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*DCONJG( V( 2, M
) )
U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*DCONJG( V( 3, M
) )
60 CONTINUE
ELSE IF( WANTZ ) THEN
DO 70 J = ILOZ, IHIZ
REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* Z( J, K+2 )+V(
3, M )*Z( J, K+3 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*DCONJG( V( 2, M ) )
Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*DCONJG( V( 3, M ) )
70 CONTINUE
END IF
END IF
80 CONTINUE
K = KRCOL + 3*( M22-1 )
IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
DO 90 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* H( J, K+2 )
)
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) - REFSUM*DCONJG( V( 2, M22 )
)
90 CONTINUE
IF( ACCUM ) THEN
KMS = K - INCOL
DO 100 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* U( J,
KMS+2 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*DCONJG( V( 2,
M22 ) )
100 CONTINUE
ELSE IF( WANTZ ) THEN
DO 110 J = ILOZ, IHIZ
REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* Z( J, K+2 )
)
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*DCONJG( V( 2, M22 )
)
110 CONTINUE
END IF
END IF
MSTART = MTOP
IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) MSTART = MSTART + 1
MEND = MBOT
IF( BMP22 ) MEND = MEND + 1
IF( KRCOL.EQ.KBOT-2 ) MEND = MEND + 1
DO 120 M = MSTART, MEND
K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
IF( H( K+1, K ).NE.ZERO ) THEN
TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) )
IF( TST1.EQ.RZERO ) THEN
IF( K.GE.KTOP+1 ) TST1 = TST1 + CABS1( H( K, K-1 ) )
IF( K.GE.KTOP+2 ) TST1 = TST1 + CABS1( H( K, K-2 ) )
IF( K.GE.KTOP+3 ) TST1 = TST1 + CABS1( H( K, K-3 ) )
IF( K.LE.KBOT-2 ) TST1 = TST1 + CABS1( H( K+2, K+1 ) )
IF( K.LE.KBOT-3 ) TST1 = TST1 + CABS1( H( K+3, K+1 ) )
IF( K.LE.KBOT-4 ) TST1 = TST1 + CABS1( H( K+4, K+1 ) )
END IF
IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
THEN
H12 = MAX( CABS1( H( K+1, K ) ), CABS1( H( K, K+1 ) ) )
H21 = MIN( CABS1( H( K+1, K ) ), CABS1( H( K, K+1 ) ) )
H11 = MAX( CABS1( H( K+1, K+1 ) ), CABS1( H( K, K )-H(
K+1, K+1 ) ) )
H22 = MIN( CABS1( H( K+1, K+1 ) ), CABS1( H( K, K )-H(
K+1, K+1 ) ) )
SCL = H11 + H12
TST2 = H22*( H11 / SCL )
IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. MAX( SML‐
NUM, ULP*TST2 ) )H( K+1, K ) = ZERO
END IF
END IF
120 CONTINUE
MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
DO 130 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
H( K+4, K+1 ) = -REFSUM
H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) )
H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*DCONJG( V( 3, M
) )
130 CONTINUE
140 CONTINUE
IF( ACCUM ) THEN
IF( WANTT ) THEN
JTOP = 1
JBOT = N
ELSE
JTOP = KTOP
JBOT = KBOT
END IF
IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. (
NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
K1 = MAX( 1, KTOP-INCOL )
NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, LDWH )
CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, H( INCOL+K1, JCOL
), LDH )
150 CONTINUE
DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, H( JROW,
INCOL+K1 ), LDH, U( K1, K1 ), LDU, ZERO, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, H( JROW, INCOL+K1
), LDH )
160 CONTINUE
IF( WANTZ ) THEN
DO 170 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, Z( JROW,
INCOL+K1 ), LDZ, U( K1, K1 ), LDU, ZERO, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, Z( JROW, INCOL+K1
), LDZ )
170 CONTINUE
END IF
ELSE
I2 = ( KDU+1 ) / 2
I4 = KDU
J2 = I4 - I2
J4 = KDU
KZS = ( J4-J2 ) - ( NS+1 )
KNZ = NS + 1
DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
LDH, WH( KZS+1, 1 ), LDWH )
CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, U( J2+1,
1+KZS ), LDU, WH( KZS+1, 1 ), LDWH )
CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, H(
INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
WH( I2+1, 1 ), LDWH )
CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, U( 1, I2+1
), LDU, WH( I2+1, 1 ), LDWH )
CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, U( J2+1,
I2+1 ), LDU, H( INCOL+1+J2, JCOL ), LDH, ONE, WH(
I2+1, 1 ), LDWH )
CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, H( INCOL+1, JCOL
), LDH )
180 CONTINUE
DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
LDH, WV( 1, 1+KZS ), LDWV )
CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, U( J2+1,
1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )
CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, H( JROW, INCOL+1
), LDH, U, LDU, ONE, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
WV( 1, 1+I2 ), LDWV )
CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, U( 1,
I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, H( JROW,
INCOL+1+J2 ), LDH, U( J2+1, I2+1 ), LDU, ONE, WV( 1,
1+I2 ), LDWV )
CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, H( JROW, INCOL+1
), LDH )
190 CONTINUE
IF( WANTZ ) THEN
DO 200 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
CALL ZLACPY( 'ALL', JLEN, KNZ, Z( JROW, INCOL+1+J2 ),
LDZ, WV( 1, 1+KZS ), LDWV )
CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, U( J2+1,
1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )
CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, Z( JROW, INCOL+1
), LDZ, U, LDU, ONE, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), LDZ,
WV( 1, 1+I2 ), LDWV )
CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, U( 1,
I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, Z( JROW,
INCOL+1+J2 ), LDZ, U( J2+1, I2+1 ), LDU, ONE, WV( 1,
1+I2 ), LDWV )
CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, Z( JROW, INCOL+1
), LDZ )
200 CONTINUE
END IF
END IF
END IF
210 CONTINUE
END
PURPOSE
LAPACK auxiliary routine (versioNovember 2008 ZLAQR5(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
|