claqr5.3lapack

Langue: en

Version: 284429 (debian - 07/07/09)

Section: 3 (Bibliothèques de fonctions)

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( 'SAFE MINIMUM' )

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

    
NDCOL = INCOL + KDU

    
IF( ACCUM ) CALL CLASET( 'ALL', 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( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, LDWH )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
200 CONTINUE

    
END IF

    
END IF

    
END IF

    
210 CONTINUE

    
END

PURPOSE