zlaqr5 (l) - Linux Man Pages

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( aqSAFE MINIMUMaq )

    
SAFMAX = RONE / SAFMIN

    
CALL DLABAD( SAFMIN, SAFMAX )

    
ULP = DLAMCH( aqPRECISIONaq )

    
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( aqALLaq, 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( REFSUM*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( SMLNUM, 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( aqCaq, aqNaq, NU, JLEN, NU, ONE, U( K1, K1 ), LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, LDWH )

    
CALL ZLACPY( aqALLaq, 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( aqNaq, aqNaq, JLEN, NU, NU, ONE, H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), LDU, ZERO, WV, LDWV )

    
CALL ZLACPY( aqALLaq, 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( aqNaq, aqNaq, JLEN, NU, NU, ONE, Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), LDU, ZERO, WV, LDWV )

    
CALL ZLACPY( aqALLaq, 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( aqALLaq, KNZ, JLEN, H( INCOL+1+J2, JCOL ), LDH, WH( KZS+1, 1 ), LDWH )

    
CALL ZLASET( aqALLaq, KZS, JLEN, ZERO, ZERO, WH, LDWH )

    
CALL ZTRMM( aqLaq, aqUaq, aqCaq, aqNaq, KNZ, JLEN, ONE, U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), LDWH )

    
CALL ZGEMM( aqCaq, aqNaq, I2, JLEN, J2, ONE, U, LDU, H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )

    
CALL ZLACPY( aqALLaq, J2, JLEN, H( INCOL+1, JCOL ), LDH, WH( I2+1, 1 ), LDWH )

    
CALL ZTRMM( aqLaq, aqLaq, aqCaq, aqNaq, J2, JLEN, ONE, U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )

    
CALL ZGEMM( aqCaq, aqNaq, 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( aqALLaq, 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( aqALLaq, JLEN, KNZ, H( JROW, INCOL+1+J2 ), LDH, WV( 1, 1+KZS ), LDWV )

    
CALL ZLASET( aqALLaq, JLEN, KZS, ZERO, ZERO, WV, LDWV )

    
CALL ZTRMM( aqRaq, aqUaq, aqNaq, aqNaq, JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )

    
CALL ZGEMM( aqNaq, aqNaq, JLEN, I2, J2, ONE, H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, LDWV )

    
CALL ZLACPY( aqALLaq, JLEN, J2, H( JROW, INCOL+1 ), LDH, WV( 1, 1+I2 ), LDWV )

    
CALL ZTRMM( aqRaq, aqLaq, aqNaq, aqNaq, JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )

    
CALL ZGEMM( aqNaq, aqNaq, 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( aqALLaq, 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( aqALLaq, JLEN, KNZ, Z( JROW, INCOL+1+J2 ), LDZ, WV( 1, 1+KZS ), LDWV )

    
CALL ZLASET( aqALLaq, JLEN, KZS, ZERO, ZERO, WV, LDWV )

    
CALL ZTRMM( aqRaq, aqUaq, aqNaq, aqNaq, JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )

    
CALL ZGEMM( aqNaq, aqNaq, JLEN, I2, J2, ONE, Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, WV, LDWV )

    
CALL ZLACPY( aqALLaq, JLEN, J2, Z( JROW, INCOL+1 ), LDZ, WV( 1, 1+I2 ), LDWV )

    
CALL ZTRMM( aqRaq, aqLaq, aqNaq, aqNaq, JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )

    
CALL ZGEMM( aqNaq, aqNaq, 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( aqALLaq, JLEN, KDU, WV, LDWV, Z( JROW, INCOL+1 ), LDZ )

    
200 CONTINUE

    
END IF

    
END IF

    
END IF

    
210 CONTINUE

    
END

PURPOSE