dlaqr5(l) - Linux man page

Name

Synopsis

SUBROUTINE DLAQR5( 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

DOUBLE

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

DOUBLE

PRECISION ZERO, ONE

PARAMETER

( ZERO = 0.0d0, ONE = 1.0d0 )

DOUBLE

PRECISION 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

DOUBLE

PRECISION DLAMCH

EXTERNAL

DLAMCH

INTRINSIC

ABS, DBLE, MAX, MIN, MOD

DOUBLE

PRECISION VT( 3 )

EXTERNAL

DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, DTRMM

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

= DLAMCH( 'SAFE MINIMUM' )

SAFMAX

= ONE / SAFMIN

CALL

DLABAD( SAFMIN, SAFMAX )

ULP

= DLAMCH( 'PRECISION' )

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

220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2

NDCOL

= INCOL + KDU

IF(

ACCUM ) CALL DLASET( '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

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

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

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

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

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

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

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

ELSE

BETA

= H( K+1, K )

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

CALL

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

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

CALL

DLACPY( '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

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

CALL

DLACPY( '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

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

CALL

DLACPY( '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

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

CALL

DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )

CALL

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

CALL

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

CALL

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

CALL

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

CALL

DGEMM( '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

DLACPY( '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

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

CALL

DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )

CALL

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

CALL

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

CALL

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

CALL

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

CALL

DGEMM( '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

DLACPY( '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

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

CALL

DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )

CALL

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

CALL

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

CALL

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

CALL

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

CALL

DGEMM( '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

DLACPY( 'ALL', JLEN, KDU, WV, LDWV, Z( JROW, INCOL+1 ), LDZ )

210

CONTINUE

END

220

CONTINUE

END

dlaqr5(l) - Linux man page

Name

Synopsis

Purpose