Homepage > Man Pages > Category > Subroutines
Homepage > Man Pages > Name > Z

zlaqr5

man page of zlaqr5

zlaqr5:

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 ) THEN IF ( 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 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
LAPACK auxiliary routine (versionMarch02011 ZLAQR5(3)
 
 
 

Copyright © 2011–2018 by topics-of-interest.com . All rights reserved. Hosted by all-inkl.
Contact · Imprint · Privacy

Page generated in 52.53ms.

roboter.name | brauchbar.de | brennholz-eichelberg.de