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( 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 SLAQR1( 3, H( K+1, K+1 ), LDH,
SR( 2*M-1 ), SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), VT ) ALPHA = VT( 1 ) CALL
SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) REFSUM = VT( 1 )*( H( K+1, K )+VT( 2
)* H( K+2, K ) ) IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ ABS( REFSUM*VT( 3 )
).GT.ULP* ( ABS( H( K, K ) )+ABS( H( K+1, K+1 ) )+ABS( 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 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 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