CLAQR5(3f)

NAME

SYNOPSIS

SUBROUTINE CLAQR5(
    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
    H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), WH( LDWH, * ), 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
    ALPHA, BETA, CDUM, REFSUM

REAL
    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

REAL
    SLAMCH

EXTERNAL
    SLAMCH

INTRINSIC
    ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL

COMPLEX
    VT( 3 )

EXTERNAL
    CGEMM, CLACPY, CLAQR1, CLARFG, CLASET, CTRMM, SLABAD

REAL
    CABS1

CABS1(
    CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )

IF( NSHFTS.LT.2 ) RETURN

IF( KTOP.GE.KBOT ) RETURN

NS  = NSHFTS - MOD( NSHFTS, 2 )

SAFMIN
    = SLAMCH( 'SAFE MINIMUM' )

SAFMAX
    = RONE / SAFMIN

CALL
    SLABAD( SAFMIN, SAFMAX )

ULP = SLAMCH( 'PRECISION' )

SMLNUM
    = SAFMIN*( REAL( 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 CLASET( '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
    CLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), S( 2*M ), V( 1, M ) )

ALPHA
    = V( 1, M )

CALL
    CLARFG( 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
    CLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )

IF( V( 1, M ).NE.ZERO .AND. ( V( 3, M ).NE.ZERO .OR. ( H( K+3, K+1 ).EQ.ZERO .AND. 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
    CLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), S( 2*M ), VT )

SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + CABS1( VT( 3 ) )

IF( SCL.NE.RZERO ) THEN

VT( 1 ) = VT( 1 ) / SCL

VT( 2 ) = VT( 2 ) / SCL

VT( 3 ) = VT( 3 ) / SCL

END IF

IF( CABS1( H( K+1, K ) )* ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* CABS1( VT( 1 ) )*( CABS1( H( K, K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN

IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) THEN

V(  1, M ) = ZERO

ELSE

H(  K+1, K ) = BETA

H(  K+2, K ) = ZERO

H(  K+3, K ) = ZERO

END IF

ELSE

ALPHA
    = VT( 1 )

CALL
    CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )

REFSUM
    = H( K+1, K ) + H( K+2, K )*CONJG( VT( 2 ) ) + H( K+3, K )*CONJG( VT( 3 ) )

H(  K+1, K ) = H( K+1, K ) - CONJG( VT( 1 ) )*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
    CLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), S( 2*M22 ), V( 1, M22 ) )

BETA
    = V( 1, M22 )

CALL
    CLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )

ELSE

BETA
    = H( K+1, K )

V(  2, M22 ) = H( K+2, K )

CALL
    CLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )

H(  K+1, K ) = BETA

H(  K+2, K ) = ZERO

END IF

ELSE

V(  1, M22 ) = ZERO

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
    = CONJG( V( 1, M ) )* ( H( K+1, J )+CONJG( V( 2, M ) )*H( K+2, J )+ CONJG( 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
    = CONJG( V( 1, M22 ) )* ( H( K+1, J )+CONJG( 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*CONJG( V( 2, M ) )

H(  J, K+3 ) = H( J, K+3 ) - REFSUM*CONJG( 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*CONJG( V( 2, M ) )

U(  J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*CONJG( 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*CONJG( V( 2, M ) )

Z(  J, K+3 ) = Z( J, K+3 ) - REFSUM*CONJG( 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*CONJG( 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*CONJG( 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*CONJG( 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*CONJG( V( 2, M ) )

H(  K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*CONJG( 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
    CGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, LDWH )

CALL
    CLACPY( '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
    CGEMM( 'N', 'N', JLEN, NU, NU, ONE, H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), LDU, ZERO, WV, LDWV )

CALL
    CLACPY( '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
    CGEMM( 'N', 'N', JLEN, NU, NU, ONE, Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), LDU, ZERO, WV, LDWV )

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

CALL
    CLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )

CALL
    CTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), LDWH )

CALL
    CGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )

CALL
    CLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, WH( I2+1, 1 ), LDWH )

CALL
    CTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )

CALL
    CGEMM( '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
    CLACPY( '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
    CLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), LDH, WV( 1, 1+KZS ), LDWV )

CALL
    CLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )

CALL
    CTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )

CALL
    CGEMM( 'N', 'N', JLEN, I2, J2, ONE, H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, LDWV )

CALL
    CLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, WV( 1, 1+I2 ), LDWV )

CALL
    CTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )

CALL
    CGEMM( '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
    CLACPY( '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
    CLACPY( 'ALL', JLEN, KNZ, Z( JROW, INCOL+1+J2 ), LDZ, WV( 1, 1+KZS ), LDWV )

CALL
    CLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )

CALL
    CTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )

CALL
    CGEMM( 'N', 'N', JLEN, I2, J2, ONE, Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, WV, LDWV )

CALL
    CLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), LDZ, WV( 1, 1+I2 ), LDWV )

CALL
    CTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )

CALL
    CGEMM( '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
    CLACPY( 'ALL', JLEN, KDU, WV, LDWV, Z( JROW, INCOL+1 ), LDZ )

200 CONTINUE

END IF

END IF

END IF

210 CONTINUE

END

PURPOSE