SLAQR5(3)

NAME

SYNOPSIS

SUBROUTINE SLAQR5(
    WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, 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

REAL
    H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )

REAL
    ZERO, ONE

PARAMETER
    ( ZERO = 0.0e0, ONE = 1.0e0 )

REAL
    ALPHA, BETA, H11, H12, H21, H22, REFSUM, SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, ULP

INTEGER
    I, 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, MAX, MIN, MOD, REAL

REAL
    VT( 3 )

EXTERNAL
    SGEMM, SLABAD, SLACPY, SLAQR1, SLARFG, SLASET, STRMM

IF( NSHFTS.LT.2 ) RETURN

IF( KTOP.GE.KBOT ) RETURN

DO  10 I = 1, NSHFTS - 2, 2

IF( SI( I ).NE.-SI( I+1 ) ) THEN

SWAP
    = SR( I )

SR( I ) = SR( I+1 )

SR( I+1 ) = SR( I+2 )

SR( I+2 ) = SWAP

SWAP
    = SI( I )

SI( I ) = SI( I+1 )

SI( I+1 ) = SI( I+2 )

SI( I+2 ) = SWAP

END IF

10  CONTINUE

NS  = NSHFTS - MOD( NSHFTS, 2 )

SAFMIN
    = SLAMCH( 'SAFE MINIMUM' )

SAFMAX
    = ONE / 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  220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2

NDCOL
    = INCOL + KDU

IF( ACCUM ) CALL SLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )

DO  150 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  20 M = MTOP, MBOT

K   = KRCOL + 3*( M-1 )

IF( K.EQ.KTOP-1 ) THEN

CALL
    SLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), V( 1, M ) )

ALPHA
    = V( 1, M )

CALL
    SLARFG( 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
    SLARFG( 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
    SLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), VT )

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

IF( SCL.NE.ZERO ) THEN

VT( 1 ) = VT( 1 ) / SCL

VT( 2 ) = VT( 2 ) / SCL

VT( 3 ) = VT( 3 ) / SCL

END IF

IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )* ( ABS( H( K, K ) )+ABS( H( K+1, K+1 ) )+ABS( 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
    SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )

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

H(  K+1, K ) = H( K+1, K ) - 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

20  CONTINUE

K   = KRCOL + 3*( M22-1 )

IF( BMP22 ) THEN

IF( K.EQ.KTOP-1 ) THEN

CALL
    SLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), V( 1, M22 ) )

BETA
    = V( 1, M22 )

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

ELSE

BETA
    = H( K+1, K )

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

CALL
    SLARFG( 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  40 J = MAX( KTOP, KRCOL ), JBOT

MEND
    = MIN( MBOT, ( J-KRCOL+2 ) / 3 )

DO  30 M = MTOP, MEND

K   = KRCOL + 3*( M-1 )

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

30  CONTINUE

40  CONTINUE

IF( BMP22 ) THEN

K   = KRCOL + 3*( M22-1 )

DO  50 J = MAX( K+1, KTOP ), JBOT

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

50  CONTINUE

END IF

IF( ACCUM ) THEN

JTOP
    = MAX( KTOP, INCOL )

ELSE
    IF( WANTT ) THEN

JTOP
    = 1

ELSE

JTOP
    = KTOP

END IF

DO  90 M = MTOP, MBOT

IF( V( 1, M ).NE.ZERO ) THEN

K   = KRCOL + 3*( M-1 )

DO  60 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*V( 2, M )

H(  J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M )

60  CONTINUE

IF( ACCUM ) THEN

KMS = K - INCOL

DO  70 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*V( 2, M )

U(  J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M )

70  CONTINUE

ELSE
    IF( WANTZ ) THEN

DO  80 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*V( 2, M )

Z(  J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M )

80  CONTINUE

END IF

END IF

90  CONTINUE

K   = KRCOL + 3*( M22-1 )

IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN

DO  100 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*V( 2, M22 )

100 CONTINUE

IF( ACCUM ) THEN

KMS = K - INCOL

DO  110 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*V( 2, M22 )

110 CONTINUE

ELSE
    IF( WANTZ ) THEN

DO  120 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*V( 2, M22 )

120 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  130 M = MSTART, MEND

K   = MIN( KBOT-1, KRCOL+3*( M-1 ) )

IF( H( K+1, K ).NE.ZERO ) THEN

TST1
    = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) )

IF( TST1.EQ.ZERO ) THEN

IF( K.GE.KTOP+1 ) TST1 = TST1 + ABS( H( K, K-1 ) )

IF( K.GE.KTOP+2 ) TST1 = TST1 + ABS( H( K, K-2 ) )

IF( K.GE.KTOP+3 ) TST1 = TST1 + ABS( H( K, K-3 ) )

IF( K.LE.KBOT-2 ) TST1 = TST1 + ABS( H( K+2, K+1 ) )

IF( K.LE.KBOT-3 ) TST1 = TST1 + ABS( H( K+3, K+1 ) )

IF( K.LE.KBOT-4 ) TST1 = TST1 + ABS( H( K+4, K+1 ) )

END IF

IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) THEN

H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )

H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )

H11 = MAX( ABS( H( K+1, K+1 ) ), ABS( H( K, K )-H( K+1, K+1 ) ) )

H22 = MIN( ABS( H( K+1, K+1 ) ), ABS( H( K, K )-H( K+1, K+1 ) ) )

SCL = H11 + H12

TST2
    = H22*( H11 / SCL )

IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO

END IF

END IF

130 CONTINUE

MEND
    = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )

DO  140 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*V( 2, M )

H(  K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M )

140 CONTINUE

150 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  160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH

JLEN
    = MIN( NH, JBOT-JCOL+1 )

CALL
    SGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, LDWH )

CALL
    SLACPY( 'ALL', NU, JLEN, WH, LDWH, H( INCOL+K1, JCOL ), LDH )

160 CONTINUE

DO  170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV

JLEN
    = MIN( NV, MAX( KTOP, INCOL )-JROW )

CALL
    SGEMM( 'N', 'N', JLEN, NU, NU, ONE, H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), LDU, ZERO, WV, LDWV )

CALL
    SLACPY( 'ALL', JLEN, NU, WV, LDWV, H( JROW, INCOL+K1 ), LDH )

170 CONTINUE

IF( WANTZ ) THEN

DO  180 JROW = ILOZ, IHIZ, NV

JLEN
    = MIN( NV, IHIZ-JROW+1 )

CALL
    SGEMM( 'N', 'N', JLEN, NU, NU, ONE, Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), LDU, ZERO, WV, LDWV )

CALL
    SLACPY( 'ALL', JLEN, NU, WV, LDWV, Z( JROW, INCOL+K1 ), LDZ )

180 CONTINUE

END IF

ELSE

I2  = ( KDU+1 ) / 2

I4  = KDU

J2  = I4 - I2

J4  = KDU

KZS = ( J4-J2 ) - ( NS+1 )

KNZ = NS + 1

DO  190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH

JLEN
    = MIN( NH, JBOT-JCOL+1 )

CALL
    SLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), LDH, WH( KZS+1, 1 ), LDWH )

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

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

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

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

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

CALL
    SGEMM( '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
    SLACPY( 'ALL', KDU, JLEN, WH, LDWH, H( INCOL+1, JCOL ), LDH )

190 CONTINUE

DO  200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV

JLEN
    = MIN( NV, MAX( INCOL, KTOP )-JROW )

CALL
    SLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), LDH, WV( 1, 1+KZS ), LDWV )

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

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

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

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

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

CALL
    SGEMM( '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
    SLACPY( 'ALL', JLEN, KDU, WV, LDWV, H( JROW, INCOL+1 ), LDH )

200 CONTINUE

IF( WANTZ ) THEN

DO  210 JROW = ILOZ, IHIZ, NV

JLEN
    = MIN( NV, IHIZ-JROW+1 )

CALL
    SLACPY( 'ALL', JLEN, KNZ, Z( JROW, INCOL+1+J2 ), LDZ, WV( 1, 1+KZS ), LDWV )

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

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

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

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

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

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

210 CONTINUE

END IF

END IF

END IF

220 CONTINUE

END

PURPOSE