claqr5 (l) - Linux Manuals

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( aqSAFE MINIMUMaq )

    

SAFMAX = RONE / SAFMIN

    

CALL SLABAD( SAFMIN, SAFMAX )

    

ULP = SLAMCH( aqPRECISIONaq )

    

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( aqALLaq, 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( 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 CLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), S( 2*M ), VT )

    

ALPHA = VT( 1 )

    

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

    

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

    

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

    

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

    

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( aqCaq, aqNaq, NU, JLEN, NU, ONE, U( K1, K1 ), LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, LDWH )

    

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

    

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

    

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

    

CALL CLASET( aqALLaq, KZS, JLEN, ZERO, ZERO, WH, LDWH )

    

CALL CTRMM( aqLaq, aqUaq, aqCaq, aqNaq, KNZ, JLEN, ONE, U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), LDWH )

    

CALL CGEMM( aqCaq, aqNaq, I2, JLEN, J2, ONE, U, LDU, H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )

    

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

    

CALL CTRMM( aqLaq, aqLaq, aqCaq, aqNaq, J2, JLEN, ONE, U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )

    

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

    

CALL CLASET( aqALLaq, JLEN, KZS, ZERO, ZERO, WV, LDWV )

    

CALL CTRMM( aqRaq, aqUaq, aqNaq, aqNaq, JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )

    

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

    

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

    

CALL CTRMM( aqRaq, aqLaq, aqNaq, aqNaq, JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )

    

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

    

CALL CLASET( aqALLaq, JLEN, KZS, ZERO, ZERO, WV, LDWV )

    

CALL CTRMM( aqRaq, aqUaq, aqNaq, aqNaq, JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV )

    

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

    

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

    

CALL CTRMM( aqRaq, aqLaq, aqNaq, aqNaq, JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )

    

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

    

200 CONTINUE

    

END IF

    

END IF

    

END IF

    

210 CONTINUE

    

END

PURPOSE