--- name: "zlaqr5" section: "3lapack" platform: "linux" package: "liblapack-doc" version: "3.2.1-8" release: "Debian 6.0 (Squeeze)" platforms: ["linux"] url: "https://new.carta.tech/zlaqr5/3lapack" --- # zlaqr5(3lapack) ## NAME ## SYNOPSIS - SUBROUTINE ZLAQR5( 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\*16 H( LDH, \* ), S( \* ), U( LDU, \* ), V( LDV, \* ), WH( LDWH, \* ), WV( LDWV, \* ), Z( LDZ, \* ) - COMPLEX\*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), ONE = ( 1.0d0, 0.0d0 ) ) - DOUBLE PRECISION RZERO, RONE - PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) - COMPLEX\*16 ALPHA, BETA, CDUM, REFSUM - DOUBLE PRECISION 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 - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD - COMPLEX\*16 VT( 3 ) - EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, ZTRMM - DOUBLE PRECISION CABS1 - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) - IF( NSHFTS.LT.2 ) RETURN - IF( KTOP.GE.KBOT ) RETURN - NS \= NSHFTS - MOD( NSHFTS, 2 ) - SAFMIN \= DLAMCH( 'SAFE MINIMUM' ) - SAFMAX \= RONE / 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 - DO 210 INCOL = 3\*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3\*NBMPS - 2 - NDCOL \= INCOL + KDU - IF( ACCUM ) CALL ZLASET( '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 ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2\*M-1 ), S( 2\*M ), V( 1, M ) ) - ALPHA \= V( 1, M ) - CALL ZLARFG( 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 ZLARFG( 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 ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2\*M-1 ), S( 2\*M ), VT ) - ALPHA \= VT( 1 ) - CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM \= DCONJG( VT( 1 ) )\* ( H( K+1, K )+DCONJG( 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 ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2\*M22-1 ), S( 2\*M22 ), V( 1, M22 ) ) - BETA \= V( 1, M22 ) - CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) - ELSE - BETA \= H( K+1, K ) - V( 2, M22 ) = H( K+2, K ) - CALL ZLARFG( 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 \= DCONJG( V( 1, M ) )\* ( H( K+1, J )+DCONJG( V( 2, M ) )\* H( K+2, J )+DCONJG( 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 \= DCONJG( V( 1, M22 ) )\* ( H( K+1, J )+DCONJG( 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\*DCONJG( V( 2, M ) ) - H( J, K+3 ) = H( J, K+3 ) - REFSUM\*DCONJG( 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\*DCONJG( V( 2, M ) ) - U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM\*DCONJG( 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\*DCONJG( V( 2, M ) ) - Z( J, K+3 ) = Z( J, K+3 ) - REFSUM\*DCONJG( 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\*DCONJG( 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\*DCONJG( 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\*DCONJG( 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\*DCONJG( V( 2, M ) ) - H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM\*DCONJG( 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 ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, LDWH ) - CALL ZLACPY( '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 ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), LDU, ZERO, WV, LDWV ) - CALL ZLACPY( '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 ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), LDU, ZERO, WV, LDWV ) - CALL ZLACPY( '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 ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), LDH, WH( KZS+1, 1 ), LDWH ) - CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) - CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), LDWH ) - CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) - CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, WH( I2+1, 1 ), LDWH ) - CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) - CALL ZGEMM( '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 ZLACPY( '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 ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), LDH, WV( 1, 1+KZS ), LDWV ) - CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) - CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV ) - CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, LDWV ) - CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, WV( 1, 1+I2 ), LDWV ) - CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) - CALL ZGEMM( '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 ZLACPY( '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 ZLACPY( 'ALL', JLEN, KNZ, Z( JROW, INCOL+1+J2 ), LDZ, WV( 1, 1+KZS ), LDWV ) - CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) - CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), LDWV ) - CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, WV, LDWV ) - CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), LDZ, WV( 1, 1+I2 ), LDWV ) - CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) - CALL ZGEMM( '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 ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, Z( JROW, INCOL+1 ), LDZ ) - 200 CONTINUE - END IF - END IF - END IF - 210 CONTINUE - END ## PURPOSE