Mercurial > octave-nkf
diff libcruft/lapack/claqr1.f @ 7789:82be108cc558
First attempt at single precision tyeps
* * *
corrections to qrupdate single precision routines
* * *
prefer demotion to single over promotion to double
* * *
Add single precision support to log2 function
* * *
Trivial PROJECT file update
* * *
Cache optimized hermitian/transpose methods
* * *
Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author | David Bateman <dbateman@free.fr> |
---|---|
date | Sun, 27 Apr 2008 22:34:17 +0200 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/libcruft/lapack/claqr1.f Sun Apr 27 22:34:17 2008 +0200 @@ -0,0 +1,97 @@ + SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + COMPLEX S1, S2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + COMPLEX H( LDH, * ), V( * ) +* .. +* +* Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a +* scalar multiple of the first column of the product +* +* (*) K = (H - s1*I)*(H - s2*I) +* +* scaling to avoid overflows and most underflows. +* +* This is useful for starting double implicit shift bulges +* in the QR algorithm. +* +* +* N (input) integer +* Order of the matrix H. N must be either 2 or 3. +* +* H (input) COMPLEX array of dimension (LDH,N) +* The 2-by-2 or 3-by-3 matrix H in (*). +* +* LDH (input) integer +* The leading dimension of H as declared in +* the calling procedure. LDH.GE.N +* +* S1 (input) COMPLEX +* S2 S1 and S2 are the shifts defining K in (*) above. +* +* V (output) COMPLEX array of dimension N +* A scalar multiple of the first column of the +* matrix K in (*). +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0e0 ) +* .. +* .. Local Scalars .. + COMPLEX CDUM + REAL H21S, H31S, S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, REAL +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + IF( S.EQ.RZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* + $ ( ( H( 1, 1 )-S2 ) / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + END IF + ELSE + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + + $ CABS1( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) + END IF + END IF + END