diff libcruft/lapack/chseqr.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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/chseqr.f
@@ -0,0 +1,395 @@
+      SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
+      CHARACTER          COMPZ, JOB
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*     Purpose
+*     =======
+*
+*     CHSEQR computes the eigenvalues of a Hessenberg matrix H
+*     and, optionally, the matrices T and Z from the Schur decomposition
+*     H = Z T Z**H, where T is an upper triangular matrix (the
+*     Schur form), and Z is the unitary matrix of Schur vectors.
+*
+*     Optionally Z may be postmultiplied into an input unitary
+*     matrix Q so that this routine can give the Schur factorization
+*     of a matrix A which has been reduced to the Hessenberg form H
+*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*
+*     Arguments
+*     =========
+*
+*     JOB   (input) CHARACTER*1
+*           = 'E':  compute eigenvalues only;
+*           = 'S':  compute eigenvalues and the Schur form T.
+*
+*     COMPZ (input) CHARACTER*1
+*           = 'N':  no Schur vectors are computed;
+*           = 'I':  Z is initialized to the unit matrix and the matrix Z
+*                   of Schur vectors of H is returned;
+*           = 'V':  Z must contain an unitary matrix Q on entry, and
+*                   the product Q*Z is returned.
+*
+*     N     (input) INTEGER
+*           The order of the matrix H.  N .GE. 0.
+*
+*     ILO   (input) INTEGER
+*     IHI   (input) INTEGER
+*           It is assumed that H is already upper triangular in rows
+*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*           set by a previous call to CGEBAL, and then passed to CGEHRD
+*           when the matrix output by CGEBAL is reduced to Hessenberg
+*           form. Otherwise ILO and IHI should be set to 1 and N
+*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*           If N = 0, then ILO = 1 and IHI = 0.
+*
+*     H     (input/output) COMPLEX array, dimension (LDH,N)
+*           On entry, the upper Hessenberg matrix H.
+*           On exit, if INFO = 0 and JOB = 'S', H contains the upper
+*           triangular matrix T from the Schur decomposition (the
+*           Schur form). If INFO = 0 and JOB = 'E', the contents of
+*           H are unspecified on exit.  (The output value of H when
+*           INFO.GT.0 is given under the description of INFO below.)
+*
+*           Unlike earlier versions of CHSEQR, this subroutine may
+*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
+*           or j = IHI+1, IHI+2, ... N.
+*
+*     LDH   (input) INTEGER
+*           The leading dimension of the array H. LDH .GE. max(1,N).
+*
+*     W        (output) COMPLEX array, dimension (N)
+*           The computed eigenvalues. If JOB = 'S', the eigenvalues are
+*           stored in the same order as on the diagonal of the Schur
+*           form returned in H, with W(i) = H(i,i).
+*
+*     Z     (input/output) COMPLEX array, dimension (LDZ,N)
+*           If COMPZ = 'N', Z is not referenced.
+*           If COMPZ = 'I', on entry Z need not be set and on exit,
+*           if INFO = 0, Z contains the unitary matrix Z of the Schur
+*           vectors of H.  If COMPZ = 'V', on entry Z must contain an
+*           N-by-N matrix Q, which is assumed to be equal to the unit
+*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
+*           if INFO = 0, Z contains Q*Z.
+*           Normally Q is the unitary matrix generated by CUNGHR
+*           after the call to CGEHRD which formed the Hessenberg matrix
+*           H. (The output value of Z when INFO.GT.0 is given under
+*           the description of INFO below.)
+*
+*     LDZ   (input) INTEGER
+*           The leading dimension of the array Z.  if COMPZ = 'I' or
+*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.
+*
+*     WORK  (workspace/output) COMPLEX array, dimension (LWORK)
+*           On exit, if INFO = 0, WORK(1) returns an estimate of
+*           the optimal value for LWORK.
+*
+*     LWORK (input) INTEGER
+*           The dimension of the array WORK.  LWORK .GE. max(1,N)
+*           is sufficient, but LWORK typically as large as 6*N may
+*           be required for optimal performance.  A workspace query
+*           to determine the optimal workspace size is recommended.
+*
+*           If LWORK = -1, then CHSEQR does a workspace query.
+*           In this case, CHSEQR checks the input parameters and
+*           estimates the optimal workspace size for the given
+*           values of N, ILO and IHI.  The estimate is returned
+*           in WORK(1).  No error message related to LWORK is
+*           issued by XERBLA.  Neither H nor Z are accessed.
+*
+*
+*     INFO  (output) INTEGER
+*             =  0:  successful exit
+*           .LT. 0:  if INFO = -i, the i-th argument had an illegal
+*                    value
+*           .GT. 0:  if INFO = i, CHSEQR failed to compute all of
+*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
+*                and WI contain those eigenvalues which have been
+*                successfully computed.  (Failures are rare.)
+*
+*                If INFO .GT. 0 and JOB = 'E', then on exit, the
+*                remaining unconverged eigenvalues are the eigen-
+*                values of the upper Hessenberg matrix rows and
+*                columns ILO through INFO of the final, output
+*                value of H.
+*
+*                If INFO .GT. 0 and JOB   = 'S', then on exit
+*
+*           (*)  (initial value of H)*U  = U*(final value of H)
+*
+*                where U is a unitary matrix.  The final
+*                value of  H is upper Hessenberg and triangular in
+*                rows and columns INFO+1 through IHI.
+*
+*                If INFO .GT. 0 and COMPZ = 'V', then on exit
+*
+*                  (final value of Z)  =  (initial value of Z)*U
+*
+*                where U is the unitary matrix in (*) (regard-
+*                less of the value of JOB.)
+*
+*                If INFO .GT. 0 and COMPZ = 'I', then on exit
+*                      (final value of Z)  = U
+*                where U is the unitary matrix in (*) (regard-
+*                less of the value of JOB.)
+*
+*                If INFO .GT. 0 and COMPZ = 'N', then Z is not
+*                accessed.
+*
+*     ================================================================
+*             Default values supplied by
+*             ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
+*             It is suggested that these defaults be adjusted in order
+*             to attain best performance in each particular
+*             computational environment.
+*
+*            ISPEC=1:  The CLAHQR vs CLAQR0 crossover point.
+*                      Default: 75. (Must be at least 11.)
+*
+*            ISPEC=2:  Recommended deflation window size.
+*                      This depends on ILO, IHI and NS.  NS is the
+*                      number of simultaneous shifts returned
+*                      by ILAENV(ISPEC=4).  (See ISPEC=4 below.)
+*                      The default for (IHI-ILO+1).LE.500 is NS.
+*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+*            ISPEC=3:  Nibble crossover point. (See ILAENV for
+*                      details.)  Default: 14% of deflation window
+*                      size.
+*
+*            ISPEC=4:  Number of simultaneous shifts, NS, in
+*                      a multi-shift QR iteration.
+*
+*                      If IHI-ILO+1 is ...
+*
+*                      greater than      ...but less    ... the
+*                      or equal to ...      than        default is
+*
+*                           1               30          NS -   2(+)
+*                          30               60          NS -   4(+)
+*                          60              150          NS =  10(+)
+*                         150              590          NS =  **
+*                         590             3000          NS =  64
+*                        3000             6000          NS = 128
+*                        6000             infinity      NS = 256
+*
+*                  (+)  By default some or all matrices of this order 
+*                       are passed to the implicit double shift routine
+*                       CLAHQR and NS is ignored.  See ISPEC=1 above 
+*                       and comments in IPARM for details.
+*
+*                       The asterisks (**) indicate an ad-hoc
+*                       function of N increasing from 10 to 64.
+*
+*            ISPEC=5:  Select structured matrix multiply.
+*                      (See ILAENV for details.) Default: 3.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*     References:
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*       929--947, 2002.
+*
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*       of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+*     ================================================================
+*     .. Parameters ..
+*
+*     ==== Matrices of order NTINY or smaller must be processed by
+*     .    CLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== NL allocates some local workspace to help small matrices
+*     .    through a rare CLAHQR failure.  NL .GT. NTINY = 11 is
+*     .    required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
+*     .    mended.  (The default value of NMIN is 75.)  Using NL = 49
+*     .    allows up to six simultaneous shifts and a 16-by-16
+*     .    deflation window.  ====
+*
+      INTEGER            NTINY
+      PARAMETER          ( NTINY = 11 )
+      INTEGER            NL
+      PARAMETER          ( NL = 49 )
+      COMPLEX            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               RZERO
+      PARAMETER          ( RZERO = 0.0e0 )
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            HL( NL, NL ), WORKL( NL )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            KBOT, NMIN
+      LOGICAL            INITZ, LQUERY, WANTT, WANTZ
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      LOGICAL            LSAME
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CLAHQR, CLAQR0, CLASET, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CMPLX, MAX, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Decode and check the input parameters. ====
+*
+      WANTT = LSAME( JOB, 'S' )
+      INITZ = LSAME( COMPZ, 'I' )
+      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+      WORK( 1 ) = CMPLX( REAL( MAX( 1, N ) ), RZERO )
+      LQUERY = LWORK.EQ.-1
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -5
+      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+*
+*        ==== Quick return in case of invalid argument. ====
+*
+         CALL XERBLA( 'CHSEQR', -INFO )
+         RETURN
+*
+      ELSE IF( N.EQ.0 ) THEN
+*
+*        ==== Quick return in case N = 0; nothing to do. ====
+*
+         RETURN
+*
+      ELSE IF( LQUERY ) THEN
+*
+*        ==== Quick return in case of a workspace query ====
+*
+         CALL CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
+     $                LDZ, WORK, LWORK, INFO )
+*        ==== Ensure reported workspace size is backward-compatible with
+*        .    previous LAPACK versions. ====
+         WORK( 1 ) = CMPLX( MAX( REAL( WORK( 1 ) ), REAL( MAX( 1,
+     $               N ) ) ), RZERO )
+         RETURN
+*
+      ELSE
+*
+*        ==== copy eigenvalues isolated by CGEBAL ====
+*
+         IF( ILO.GT.1 )
+     $      CALL CCOPY( ILO-1, H, LDH+1, W, 1 )
+         IF( IHI.LT.N )
+     $      CALL CCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 )
+*
+*        ==== Initialize Z, if requested ====
+*
+         IF( INITZ )
+     $      CALL CLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
+*
+*        ==== Quick return if possible ====
+*
+         IF( ILO.EQ.IHI ) THEN
+            W( ILO ) = H( ILO, ILO )
+            RETURN
+         END IF
+*
+*        ==== CLAHQR/CLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 1, 'CHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
+     $          IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== CLAQR0 for big matrices; CLAHQR for small ones ====
+*
+         IF( N.GT.NMIN ) THEN
+            CALL CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
+     $                   Z, LDZ, WORK, LWORK, INFO )
+         ELSE
+*
+*           ==== Small matrix ====
+*
+            CALL CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
+     $                   Z, LDZ, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+*
+*              ==== A rare CLAHQR failure!  CLAQR0 sometimes succeeds
+*              .    when CLAHQR fails. ====
+*
+               KBOT = INFO
+*
+               IF( N.GE.NL ) THEN
+*
+*                 ==== Larger matrices have enough subdiagonal scratch
+*                 .    space to call CLAQR0 directly. ====
+*
+                  CALL CLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W,
+     $                         ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
+*
+               ELSE
+*
+*                 ==== Tiny matrices don't have enough subdiagonal
+*                 .    scratch space to benefit from CLAQR0.  Hence,
+*                 .    tiny matrices must be copied into a larger
+*                 .    array before calling CLAQR0. ====
+*
+                  CALL CLACPY( 'A', N, N, H, LDH, HL, NL )
+                  HL( N+1, N ) = ZERO
+                  CALL CLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
+     $                         NL )
+                  CALL CLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W,
+     $                         ILO, IHI, Z, LDZ, WORKL, NL, INFO )
+                  IF( WANTT .OR. INFO.NE.0 )
+     $               CALL CLACPY( 'A', N, N, HL, NL, H, LDH )
+               END IF
+            END IF
+         END IF
+*
+*        ==== Clear out the trash, if necessary. ====
+*
+         IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
+     $      CALL CLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
+*
+*        ==== Ensure reported workspace size is backward-compatible with
+*        .    previous LAPACK versions. ====
+*
+         WORK( 1 ) = CMPLX( MAX( REAL( MAX( 1, N ) ),
+     $               REAL( WORK( 1 ) ) ), RZERO )
+      END IF
+*
+*     ==== End of CHSEQR ====
+*
+      END