slaqr5(l) - Linux man page

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

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

CONTINUE

= 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

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 )

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 )

20 M = MTOP, MBOT

= 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 )

2, M ) = H( K+2, K )

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

K+1, K ) = BETA

K+2, K ) = ZERO

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

K+1, K ) = BETA

K+2, K ) = ZERO

K+3, K ) = ZERO

ELSE

K+1, K ) = H( K+1, K ) - REFSUM

K+2, K ) = ZERO

K+3, K ) = ZERO

1, M ) = VT( 1 )

2, M ) = VT( 2 )

3, M ) = VT( 3 )

END

CONTINUE

= 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 )

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

CALL

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

K+1, K ) = BETA

K+2, K ) = ZERO

END

IF(

ACCUM ) THEN

JBOT

= MIN( NDCOL, KBOT )

ELSE

IF( WANTT ) THEN

JBOT

= N

ELSE

JBOT

= KBOT

END

40 J = MAX( KTOP, KRCOL ), JBOT

MEND

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

30 M = MTOP, MEND

= 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 ) )

K+1, J ) = H( K+1, J ) - REFSUM

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

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

CONTINUE

IF(

BMP22 ) THEN

= KRCOL + 3*( M22-1 )

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

REFSUM

= V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* H( K+2, J ) )

K+1, J ) = H( K+1, J ) - REFSUM

K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )

CONTINUE

END

IF(

ACCUM ) THEN

JTOP

= MAX( KTOP, INCOL )

ELSE

IF( WANTT ) THEN

JTOP

= 1

ELSE

JTOP

= KTOP

END

90 M = MTOP, MBOT

IF(

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

= KRCOL + 3*( M-1 )

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 ) )

J, K+1 ) = H( J, K+1 ) - REFSUM

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

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

CONTINUE

IF(

ACCUM ) THEN

KMS

= K - INCOL

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 ) )

J, KMS+1 ) = U( J, KMS+1 ) - REFSUM

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

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

CONTINUE

ELSE

IF( WANTZ ) THEN

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 ) )

J, K+1 ) = Z( J, K+1 ) - REFSUM

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

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

CONTINUE

END

CONTINUE

= KRCOL + 3*( M22-1 )

IF(

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

100 J = JTOP, MIN( KBOT, K+3 )

REFSUM

= V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* H( J, K+2 ) )

J, K+1 ) = H( J, K+1 ) - REFSUM

J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 )

100

CONTINUE

IF(

ACCUM ) THEN

KMS

= K - INCOL

110 J = MAX( 1, KTOP-INCOL ), KDU

REFSUM

= V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* U( J, KMS+2 ) )

J, KMS+1 ) = U( J, KMS+1 ) - REFSUM

J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 )

110

CONTINUE

ELSE

IF( WANTZ ) THEN

120 J = ILOZ, IHIZ

REFSUM

= V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* Z( J, K+2 ) )

J, K+1 ) = Z( J, K+1 ) - REFSUM

J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 )

120

CONTINUE

END

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

130 M = MSTART, MEND

= 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(

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

130

CONTINUE

MEND

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

140 M = MTOP, MEND

= KRCOL + 3*( M-1 )

REFSUM

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

K+4, K+1 ) = -REFSUM

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

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(

( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN

= MAX( 1, KTOP-INCOL )

= ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1

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

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

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

ELSE

= ( KDU+1 ) / 2

= KDU

= I4 - I2

= KDU

KZS

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

KNZ

= NS + 1

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

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

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

220

CONTINUE

END

slaqr5(l) - Linux man page

Name

Synopsis

Purpose