Mercurial > hg > octave-max
changeset 7034:68db500cb558
[project @ 2007-10-16 18:54:19 by jwe]
line wrap: on
line diff
--- a/libcruft/ChangeLog +++ b/libcruft/ChangeLog @@ -1,3 +1,14 @@ +2007-10-16 John W. Eaton <jwe@octave.org> + + * lapack/dlacn2.f, lapack/dlacn2.f, lapack/dlahr2.f, + lapack/dlahr2.f, lapack/dlaqr0.f, lapack/dlazq3.f, + lapack/dlazq3.f, lapack/dormr3.f, lapack/dormrz.f, + lapack/iparmq.f, lapack/iparmq.f, lapack/zlacn2.f, + lapack/zlahr2.f, lapack/zlaqr0.f: New files. + * lapack/Makefile.in (FSRC): Add them to the list. + + * lapack: Update all files to current versions from Lapack 3.1.1. + 2007-10-12 John W. Eaton <jwe@octave.org> * Change copyright notices in all files that are part of Octave to
--- a/libcruft/lapack/Makefile.in +++ b/libcruft/lapack/Makefile.in @@ -26,46 +26,50 @@ EXTERNAL_DISTFILES = $(DISTFILES) -FSRC = dbdsqr.f dgbcon.f dgbtf2.f dgbtrf.f dgbtrs.f dgebak.f \ - dgebal.f dgebd2.f dgebrd.f dgecon.f dgeesx.f dgeev.f dgehd2.f\ - dgehrd.f dgelq2.f dgelqf.f dgelss.f dgelsy.f dgeqp3.f dgeqpf.f \ - dgeqr2.f dgeqrf.f dgesvd.f dgesv.f dgetf2.f dgetrf.f dgetri.f \ - dgetrs.f dggbak.f dggbal.f dgghrd.f dgtsv.f dgttrf.f dgttrs.f \ - dhgeqz.f dhseqr.f dlabad.f dlabrd.f dlacon.f dlacpy.f dladiv.f \ - dlae2.f dlaev2.f dlaexc.f dlag2.f dlahqr.f dlahrd.f dlaic1.f \ - dlaln2.f dlamc1.f dlamc2.f dlamc3.f dlamc4.f dlamc5.f dlamch.f \ - dlange.f dlanhs.f dlanst.f dlansy.f dlantr.f dlanv2.f dlapy2.f \ - dlapy3.f dlaqp2.f dlaqps.f dlarfb.f dlarf.f dlarfg.f dlarft.f \ - dlarfx.f dlartg.f dlarzb.f dlarz.f dlarzt.f dlas2.f dlascl.f \ +FSRC = dbdsqr.f dgbcon.f dgbtf2.f dgbtrf.f dgbtrs.f dgebak.f dgebal.f \ + dgebd2.f dgebrd.f dgecon.f dgeesx.f dgeev.f dgehd2.f dgehrd.f \ + dgelq2.f dgelqf.f dgelss.f dgelsy.f dgeqp3.f dgeqpf.f dgeqr2.f \ + dgeqrf.f dgesv.f dgesvd.f dgetf2.f dgetrf.f dgetri.f dgetrs.f \ + dggbak.f dggbal.f dgghrd.f dgtsv.f dgttrf.f dgttrs.f dhgeqz.f \ + dhseqr.f dlabad.f dlabrd.f dlacn2.f dlacon.f dlacpy.f dladiv.f \ + dlae2.f dlaev2.f dlaexc.f dlag2.f dlahqr.f dlahr2.f dlahrd.f \ + dlaic1.f dlaln2.f dlamc1.f dlamc2.f dlamc3.f dlamc4.f dlamc5.f \ + dlamch.f dlange.f dlanhs.f dlanst.f dlansy.f dlantr.f dlanv2.f \ + dlapy2.f dlapy3.f dlaqp2.f dlaqps.f dlaqr0.f dlaqr1.f dlaqr2.f \ + dlaqr3.f dlaqr4.f dlaqr5.f dlarf.f dlarfb.f dlarfg.f dlarft.f \ + dlarfx.f dlartg.f dlarz.f dlarzb.f dlarzt.f dlas2.f dlascl.f \ dlaset.f dlasq1.f dlasq2.f dlasq3.f dlasq4.f dlasq5.f dlasq6.f \ dlasr.f dlasrt.f dlassq.f dlasv2.f dlaswp.f dlasy2.f dlatbs.f \ - dlatrd.f dlatrs.f dlatrz.f dlauu2.f dlauum.f dorg2l.f dorg2r.f \ - dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgtr.f \ - dorm2r.f dormbr.f dorml2.f dormlq.f dormqr.f dpbcon.f dpbtf2.f \ - dpbtrf.f dpbtrs.f dpocon.f dpotf2.f dpotrf.f dpotri.f dpotrs.f \ - dptsv.f dpttrf.f dpttrs.f dptts2.f drscl.f dsteqr.f dsterf.f \ - dsyev.f dsytd2.f dsytrd.f dtgevc.f dtrcon.f dtrevc.f dtrexc.f \ - dtrsen.f dtrsyl.f dtrti2.f dtrtri.f dtrtrs.f dtzrzf.f dzsum1.f \ - ieeeck.f ilaenv.f izmax1.f spotf2.f spotrf.f zbdsqr.f zdrscl.f \ - zgbcon.f zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f \ - zgebrd.f zgecon.f zgeesx.f zgeev.f zgehd2.f zgehrd.f zgelq2.f \ - zgelqf.f zgelss.f zgelsy.f zgeqp3.f zgeqpf.f zgeqr2.f zgeqrf.f \ - zgesvd.f zgesv.f zgetf2.f zgetrf.f zgetri.f zgetrs.f zggbal.f \ - zgtsv.f zgttrf.f zgttrs.f zheev.f zhetd2.f zhetrd.f zhseqr.f \ - zlabrd.f zlacgv.f zlacon.f zlacpy.f zladiv.f zlahqr.f zlahrd.f \ + dlatrd.f dlatrs.f dlatrz.f dlauu2.f dlauum.f dlazq3.f dlazq4.f \ + dorg2l.f dorg2r.f dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f \ + dorgqr.f dorgtr.f dorm2r.f dormbr.f dorml2.f dormlq.f dormqr.f \ + dormr3.f dormrz.f dpbcon.f dpbtf2.f dpbtrf.f dpbtrs.f dpocon.f \ + dpotf2.f dpotrf.f dpotri.f dpotrs.f dptsv.f dpttrf.f dpttrs.f \ + dptts2.f drscl.f dsteqr.f dsterf.f dsyev.f dsytd2.f dsytrd.f \ + dtgevc.f dtrcon.f dtrevc.f dtrexc.f dtrsen.f dtrsyl.f dtrti2.f \ + dtrtri.f dtrtrs.f dtzrzf.f dzsum1.f ieeeck.f ilaenv.f iparmq.f \ + izmax1.f spotf2.f spotrf.f zbdsqr.f zdrscl.f zgbcon.f zgbtf2.f \ + zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f zgebrd.f zgecon.f \ + zgeesx.f zgeev.f zgehd2.f zgehrd.f zgelq2.f zgelqf.f zgelss.f \ + zgelsy.f zgeqp3.f zgeqpf.f zgeqr2.f zgeqrf.f zgesv.f zgesvd.f \ + zgetf2.f zgetrf.f zgetri.f zgetrs.f zggbal.f zgtsv.f zgttrf.f \ + zgttrs.f zheev.f zhetd2.f zhetrd.f zhseqr.f zlabrd.f zlacgv.f \ + zlacn2.f zlacon.f zlacpy.f zladiv.f zlahqr.f zlahr2.f zlahrd.f \ zlaic1.f zlange.f zlanhe.f zlanhs.f zlantr.f zlaqp2.f zlaqps.f \ - zlarfb.f zlarf.f zlarfg.f zlarft.f zlarfx.f zlartg.f zlarzb.f \ - zlarz.f zlarzt.f zlascl.f zlaset.f zlasr.f zlassq.f zlaswp.f \ - zlatbs.f zlatrd.f zlatrs.f zlatrz.f zlauu2.f zlauum.f zpbcon.f \ - zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpotf2.f zpotrf.f zpotri.f \ - zpotrs.f zptsv.f zpttrf.f zpttrs.f zptts2.f zrot.f zsteqr.f \ - ztrcon.f ztrevc.f ztrexc.f ztrsen.f ztrsyl.f ztrti2.f ztrtri.f \ - ztrtrs.f ztzrzf.f zung2l.f zung2r.f zungbr.f zunghr.f zungl2.f \ - zunglq.f zungql.f zungqr.f zungtr.f zunm2r.f zunmbr.f zunml2.f \ - zunmlq.f zunmqr.f zunmr3.f zunmrz.f + zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f zlarf.f \ + zlarfb.f zlarfg.f zlarft.f zlarfx.f zlartg.f zlarz.f zlarzb.f \ + zlarzt.f zlascl.f zlaset.f zlasr.f zlassq.f zlaswp.f zlatbs.f \ + zlatrd.f zlatrs.f zlatrz.f zlauu2.f zlauum.f zpbcon.f zpbtf2.f \ + zpbtrf.f zpbtrs.f zpocon.f zpotf2.f zpotrf.f zpotri.f zpotrs.f \ + zptsv.f zpttrf.f zpttrs.f zptts2.f zrot.f zsteqr.f ztrcon.f ztrevc.f \ + ztrexc.f ztrsen.f ztrsyl.f ztrti2.f ztrtri.f ztrtrs.f ztzrzf.f \ + zung2l.f zung2r.f zungbr.f zunghr.f zungl2.f zunglq.f zungql.f \ + zungqr.f zungtr.f zunm2r.f zunmbr.f zunml2.f zunmlq.f zunmqr.f \ + zunmr3.f zunmrz.f include $(TOPDIR)/Makeconf dlamc1.o pic/dlamc1.o: FFLAGS += $(F77_FLOAT_STORE_FLAG) include ../Makerules +
--- a/libcruft/lapack/dbdsqr.f +++ b/libcruft/lapack/dbdsqr.f @@ -1,10 +1,9 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK routine (version 3.1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* January 2007 * * .. Scalar Arguments .. CHARACTER UPLO @@ -18,14 +17,26 @@ * Purpose * ======= * -* DBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. +* DBDSQR computes the singular values and, optionally, the right and/or +* left singular vectors from the singular value decomposition (SVD) of +* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit +* zero-shift QR algorithm. The SVD of B has the form +* +* B = Q * S * P**T +* +* where S is the diagonal matrix of singular values, Q is an orthogonal +* matrix of left singular vectors, and P is an orthogonal matrix of +* right singular vectors. If left singular vectors are requested, this +* subroutine actually returns U*Q instead of Q, and, if right singular +* vectors are requested, this subroutine returns P**T*VT instead of +* P**T, for given real input matrices U and VT. When U and VT are the +* orthogonal matrices that reduce a general matrix A to bidiagonal +* form: A = U*B*VT, as computed by DGEBRD, then * -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given real input matrices U, VT, and C. +* A = (U*Q) * S * (P**T*VT) +* +* is the SVD of A. Optionally, the subroutine may also compute Q**T*C +* for a given real input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, @@ -60,19 +71,18 @@ * On exit, if INFO=0, the singular values of B in decreasing * order. * -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* E (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, the N-1 offdiagonal elements of the bidiagonal +* matrix B. +* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given -* as input. E(N) is used for workspace. +* as input. * * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**T * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -81,21 +91,22 @@ * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* On exit, C is overwritten by Q**T * C. +* Not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * -* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise * * INFO (output) INTEGER * = 0: successful exit @@ -155,7 +166,7 @@ $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, - $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, + $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. @@ -415,7 +426,6 @@ E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 100 CONTINUE @@ -444,7 +454,6 @@ E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 110 CONTINUE
--- a/libcruft/lapack/dgbcon.f +++ b/libcruft/lapack/dgbcon.f @@ -1,10 +1,11 @@ SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM @@ -87,6 +88,9 @@ INTEGER IX, J, JP, KASE, KASE1, KD, LM DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX @@ -94,7 +98,7 @@ EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DAXPY, DLACON, DLATBS, DRSCL, XERBLA + EXTERNAL DAXPY, DLACN2, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN @@ -148,7 +152,7 @@ LNOTI = KL.GT.0 KASE = 0 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN *
--- a/libcruft/lapack/dgbtf2.f +++ b/libcruft/lapack/dgbtf2.f @@ -1,9 +1,8 @@ SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N
--- a/libcruft/lapack/dgbtrf.f +++ b/libcruft/lapack/dgbtrf.f @@ -1,9 +1,8 @@ SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N
--- a/libcruft/lapack/dgbtrs.f +++ b/libcruft/lapack/dgbtrs.f @@ -1,10 +1,9 @@ SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANS
--- a/libcruft/lapack/dgebak.f +++ b/libcruft/lapack/dgebak.f @@ -1,10 +1,9 @@ SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE
--- a/libcruft/lapack/dgebal.f +++ b/libcruft/lapack/dgebal.f @@ -1,9 +1,8 @@ SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOB @@ -105,7 +104,7 @@ DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 0.8D+1 ) + PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * ..
--- a/libcruft/lapack/dgebd2.f +++ b/libcruft/lapack/dgebd2.f @@ -1,9 +1,8 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -169,8 +168,9 @@ * * Apply H(i) to A(i:m,i+1:n) from the left * - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) + IF( I.LT.N ) + $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), + $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN @@ -207,8 +207,9 @@ * * Apply G(i) to A(i+1:m,i:n) from the right * - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) + IF( I.LT.M ) + $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN
--- a/libcruft/lapack/dgebrd.f +++ b/libcruft/lapack/dgebrd.f @@ -1,10 +1,9 @@ SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -70,7 +69,7 @@ * The scalar factors of the elementary reflectors which * represent the orthogonal matrix P. See Further Details. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dgecon.f +++ b/libcruft/lapack/dgecon.f @@ -1,10 +1,11 @@ SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM @@ -74,6 +75,9 @@ INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX @@ -81,7 +85,7 @@ EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DLACON, DLATRS, DRSCL, XERBLA + EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX @@ -129,7 +133,7 @@ END IF KASE = 0 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN *
--- a/libcruft/lapack/dgeesx.f +++ b/libcruft/lapack/dgeesx.f @@ -2,10 +2,9 @@ $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -63,7 +62,7 @@ * = 'N': Eigenvalues are not ordered; * = 'S': Eigenvalues are ordered (see SELECT). * -* SELECT (input) LOGICAL FUNCTION of two DOUBLE PRECISION arguments +* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments * SELECT must be declared EXTERNAL in the calling subroutine. * If SORT = 'S', SELECT is used to select eigenvalues to sort * to the top left of the Schur form. @@ -129,7 +128,7 @@ * condition number for the selected right invariant subspace. * Not referenced if SENSE = 'N' or 'E'. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -137,16 +136,32 @@ * Also, if SENSE = 'E' or 'V' or 'B', * LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of * selected eigenvalues computed by this routine. Note that -* N+2*SDIM*(N-SDIM) <= N+N*N/2. +* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only +* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or +* 'B' this may not be large enough. * For good performance, LWORK must generally be larger. * -* IWORK (workspace/output) INTEGER array, dimension (LIWORK) -* Not referenced if SENSE = 'N' or 'E'. +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates upper bounds on the optimal sizes of the +* arrays WORK and IWORK, returns these values as the first +* entries of the WORK and IWORK arrays, and no error messages +* related to LWORK or LIWORK are issued by XERBLA. +* +* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). +* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is +* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this +* may not be large enough. +* +* If LIWORK = -1, then a workspace query is assumed; the +* routine only calculates upper bounds on the optimal sizes of +* the arrays WORK and IWORK, returns these values as the first +* entries of the WORK and IWORK arrays, and no error messages +* related to LWORK or LIWORK are issued by XERBLA. * * BWORK (workspace) LOGICAL array, dimension (N) * Not referenced if SORT = 'N'. @@ -175,10 +190,10 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL CURSL, LASTSL, LST2SL, SCALEA, WANTSB, WANTSE, - $ WANTSN, WANTST, WANTSV, WANTVS + LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB, + $ WANTSE, WANTSN, WANTST, WANTSV, WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, - $ IHI, ILO, INXT, IP, ITAU, IWRK, K, MAXB, + $ IHI, ILO, INXT, IP, ITAU, IWRK, LIWRK, LWRK, $ MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM * .. @@ -193,10 +208,10 @@ LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE + EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT + INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * @@ -209,6 +224,7 @@ WANTSE = LSAME( SENSE, 'E' ) WANTSV = LSAME( SENSE, 'V' ) WANTSB = LSAME( SENSE, 'B' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN @@ -238,33 +254,42 @@ * depends on SDIM, which is computed by the routine DTRSEN later * in the code.) * - MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN - MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) - MINWRK = MAX( 1, 3*N ) - IF( .NOT.WANTVS ) THEN - MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SN', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) + IF( INFO.EQ.0 ) THEN + LIWRK = 1 + IF( N.EQ.0 ) THEN + MINWRK = 1 + LWRK = 1 ELSE - MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* - $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) - MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 3*N +* + CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, + $ WORK, -1, IEVAL ) + HSWORK = WORK( 1 ) +* + IF( .NOT.WANTVS ) THEN + MAXWRK = MAX( MAXWRK, N + HSWORK ) + ELSE + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + MAXWRK = MAX( MAXWRK, N + HSWORK ) + END IF + LWRK = MAXWRK + IF( .NOT.WANTSN ) + $ LWRK = MAX( LWRK, N + ( N*N )/2 ) + IF( WANTSV .OR. WANTSB ) + $ LIWRK = ( N*N )/4 END IF - WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWRK + WORK( 1 ) = LWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -16 + ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -18 + END IF END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -16 - END IF - IF( LIWORK.LT.1 ) THEN - INFO = -18 - END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEESX', -INFO ) RETURN @@ -490,7 +515,7 @@ * WORK( 1 ) = MAXWRK IF( WANTSV .OR. WANTSB ) THEN - IWORK( 1 ) = SDIM*( N-SDIM ) + IWORK( 1 ) = MAX( 1, SDIM*( N-SDIM ) ) ELSE IWORK( 1 ) = 1 END IF
--- a/libcruft/lapack/dgeev.f +++ b/libcruft/lapack/dgeev.f @@ -1,10 +1,9 @@ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* December 8, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -90,7 +89,7 @@ * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -121,7 +120,7 @@ LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, - $ MAXB, MAXWRK, MINWRK, NOUT + $ MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. @@ -130,8 +129,9 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, - $ DLASCL, DORGHR, DROT, DSCAL, DTREVC, XERBLA + EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, + $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, + $ XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -141,7 +141,7 @@ $ DNRM2 * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT + INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * @@ -175,32 +175,46 @@ * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * - MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN - MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) - IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN - MINWRK = MAX( 1, 3*N ) - MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 ELSE - MINWRK = MAX( 1, 4*N ) - MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* - $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) - MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) - MAXWRK = MAX( MAXWRK, 4*N ) + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + IF( WANTVL ) THEN + MINWRK = 4*N + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, + $ WORK, -1, INFO ) + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + MAXWRK = MAX( MAXWRK, 4*N ) + ELSE IF( WANTVR ) THEN + MINWRK = 4*N + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, + $ WORK, -1, INFO ) + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + MAXWRK = MAX( MAXWRK, 4*N ) + ELSE + MINWRK = 3*N + CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, + $ WORK, -1, INFO ) + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) END IF WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEV ', -INFO ) RETURN
--- a/libcruft/lapack/dgehd2.f +++ b/libcruft/lapack/dgehd2.f @@ -1,9 +1,8 @@ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N
--- a/libcruft/lapack/dgehrd.f +++ b/libcruft/lapack/dgehrd.f @@ -1,15 +1,14 @@ SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -98,25 +97,31 @@ * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * +* This file is a slight modification of LAPACK-3.0's DGEHRD +* subroutine incorporating improvements proposed by Quintana-Orti and +* Van de Geijn (2005). +* * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, - $ NH, NX - DOUBLE PRECISION EI + INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + DOUBLE PRECISION EI * .. * .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) + DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Subroutines .. - EXTERNAL DGEHD2, DGEMM, DLAHRD, DLARFB, XERBLA + EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM, + $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -169,7 +174,7 @@ RETURN END IF * -* Determine the block size. +* Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 @@ -177,19 +182,19 @@ IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). +* (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * -* Determine if workspace is large enough for blocked code. +* Determine if workspace is large enough for blocked code * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of -* unblocked code. +* unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, $ -1 ) ) @@ -213,34 +218,47 @@ * * Use blocked code * - DO 30 I = ILO, IHI - 1 - NX, NB + DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * - CALL DLAHRD( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, + CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set -* to 1. +* to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE - CALL DGEMM( 'No transpose', 'Transpose', IHI, IHI-I-IB+1, + CALL DGEMM( 'No transpose', 'Transpose', + $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE +* * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * - CALL DLARFB( 'Left', 'Transpose', 'Forward', 'Columnwise', + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, $ A( I+1, I+IB ), LDA, WORK, LDWORK ) - 30 CONTINUE + 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix
--- a/libcruft/lapack/dgelq2.f +++ b/libcruft/lapack/dgelq2.f @@ -1,9 +1,8 @@ SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N
--- a/libcruft/lapack/dgelqf.f +++ b/libcruft/lapack/dgelqf.f @@ -1,9 +1,8 @@ SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -42,7 +41,7 @@ * The scalar factors of the elementary reflectors (see Further * Details). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dgelss.f +++ b/libcruft/lapack/dgelss.f @@ -1,10 +1,9 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -78,7 +77,7 @@ * The effective rank of A, i.e., the number of singular values * which are greater than RCOND*S(1). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -134,7 +133,6 @@ INFO = 0 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) - MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 @@ -155,85 +153,91 @@ * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * - MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN - MAXWRK = 0 - MM = M - IF( M.GE.N .AND. M.GE.MNTHR ) THEN + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( MINMN.GT.0 ) THEN + MM = M + MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) + IF( M.GE.N .AND. M.GE.MNTHR ) THEN +* +* Path 1a - overdetermined, with many more rows than +* columns +* + MM = N + MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'DGEQRF', ' ', M, + $ N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'DORMQR', 'LT', + $ M, NRHS, N, -1 ) ) + END IF + IF( M.GE.N ) THEN * -* Path 1a - overdetermined, with many more rows than columns +* Path 1 - overdetermined or exactly determined +* +* Compute workspace needed for DBDSQR +* + BDSPAC = MAX( 1, 5*N ) + MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1, + $ 'DGEBRD', ' ', MM, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'DORMBR', + $ 'QLT', MM, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1, + $ 'DORGBR', 'P', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MAXWRK = MAX( MAXWRK, N*NRHS ) + MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC ) + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF + IF( N.GT.M ) THEN +* +* Compute workspace needed for DBDSQR * - MM = N - MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, - $ -1, -1 ) ) - MAXWRK = MAX( MAXWRK, N+NRHS* - $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) - END IF - IF( M.GE.N ) THEN + BDSPAC = MAX( 1, 5*M ) + MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) + IF( N.GE.MNTHR ) THEN * -* Path 1 - overdetermined or exactly determined +* Path 2a - underdetermined, with many more columns +* than rows * -* Compute workspace needed for DBDSQR + MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1, + $ 'DGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1, + $ 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + + $ ( M - 1 )*ILAENV( 1, 'DORGBR', 'P', M, + $ M, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC ) + IF( NRHS.GT.1 ) THEN + MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) + ELSE + MAXWRK = MAX( MAXWRK, M*M + 2*M ) + END IF + MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'DORMLQ', + $ 'LT', N, NRHS, M, -1 ) ) + ELSE * - BDSPAC = MAX( 1, 5*N ) - MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* - $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC ) +* Path 2 - underdetermined +* + MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'DGEBRD', ' ', M, + $ N, -1, -1 ) + MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'DORMBR', + $ 'QLT', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'DORGBR', + $ 'P', M, N, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MAXWRK = MAX( MAXWRK, N*NRHS ) + END IF + END IF MAXWRK = MAX( MINWRK, MAXWRK ) END IF - IF( N.GT.M ) THEN -* -* Compute workspace needed for DBDSQR -* - BDSPAC = MAX( 1, 5*M ) - MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) - IF( N.GE.MNTHR ) THEN -* -* Path 2a - underdetermined, with many more columns -* than rows + WORK( 1 ) = MAXWRK * - MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC ) - IF( NRHS.GT.1 ) THEN - MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) - ELSE - MAXWRK = MAX( MAXWRK, M*M+2*M ) - END IF - MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) - ELSE -* -* Path 2 - underdetermined -* - MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, - $ -1, -1 ) - MAXWRK = MAX( MAXWRK, 3*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - END IF - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) - WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSS', -INFO ) RETURN
--- a/libcruft/lapack/dgeqpf.f +++ b/libcruft/lapack/dgeqpf.f @@ -1,9 +1,8 @@ SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * -* -- LAPACK test routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK deprecated driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -75,6 +74,12 @@ * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * +* Partial column norm updating strategy modified by +* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, +* University of Zagreb, Croatia. +* June 2006. +* For more details see LAPACK Working Note 176. +* * ===================================================================== * * .. Parameters .. @@ -83,7 +88,7 @@ * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT - DOUBLE PRECISION AII, TEMP, TEMP2 + DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA @@ -93,8 +98,8 @@ * .. * .. External Functions .. INTEGER IDAMAX - DOUBLE PRECISION DNRM2 - EXTERNAL IDAMAX, DNRM2 + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. Executable Statements .. * @@ -114,6 +119,7 @@ END IF * MN = MIN( M, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) * * Move initial columns up front * @@ -195,11 +201,14 @@ * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN - TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + 0.05D0*TEMP* - $ ( WORK( J ) / WORK( N+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / WORK( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J )
--- a/libcruft/lapack/dgeqr2.f +++ b/libcruft/lapack/dgeqr2.f @@ -1,9 +1,8 @@ SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N
--- a/libcruft/lapack/dgeqrf.f +++ b/libcruft/lapack/dgeqrf.f @@ -1,9 +1,8 @@ SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -43,7 +42,7 @@ * The scalar factors of the elementary reflectors (see Further * Details). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dgesv.f +++ b/libcruft/lapack/dgesv.f @@ -1,9 +1,8 @@ SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS
--- a/libcruft/lapack/dgesvd.f +++ b/libcruft/lapack/dgesvd.f @@ -1,10 +1,9 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -105,7 +104,7 @@ * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK; * if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged * superdiagonal elements of an upper bidiagonal matrix B @@ -114,8 +113,8 @@ * as A, and singular vectors related by U and VT. * * LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1. -* LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). +* The dimension of the array WORK. +* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine @@ -169,7 +168,6 @@ * INFO = 0 MINMN = MIN( M, N ) - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) WNTUA = LSAME( JOBU, 'A' ) WNTUS = LSAME( JOBU, 'S' ) WNTUAS = WNTUA .OR. WNTUS @@ -180,7 +178,6 @@ WNTVAS = WNTVA .OR. WNTVS WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) - MINWRK = 1 LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN @@ -208,12 +205,14 @@ * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. - $ N.GT.0 ) THEN - IF( M.GE.N ) THEN + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Compute space needed for DBDSQR * + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) BDSPAC = 5*N IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN @@ -229,7 +228,6 @@ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') @@ -244,7 +242,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or @@ -262,7 +259,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') @@ -277,7 +273,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') @@ -294,7 +289,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or @@ -312,7 +306,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') @@ -327,7 +320,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') @@ -344,7 +336,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or @@ -362,7 +353,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF ELSE * @@ -381,12 +371,12 @@ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF - ELSE + ELSE IF( MINMN.GT.0 ) THEN * * Compute space needed for DBDSQR * + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) BDSPAC = 5*M IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN @@ -402,7 +392,6 @@ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') @@ -417,7 +406,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', @@ -435,7 +423,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') @@ -450,7 +437,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') @@ -467,7 +453,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', @@ -485,7 +470,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') @@ -500,7 +484,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') @@ -517,7 +500,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', @@ -535,7 +517,6 @@ WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF ELSE * @@ -554,15 +535,16 @@ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF END IF + MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVD', -INFO ) RETURN @@ -573,8 +555,6 @@ * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * @@ -822,8 +802,9 @@ * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), - $ LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (Workspace: need N*N+2*N, prefer N*N+N+N*NB) @@ -896,8 +877,9 @@ * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), - $ LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (Workspace: need 2*N, prefer N+N*NB) @@ -1358,8 +1340,9 @@ * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), - $ LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N @@ -1834,8 +1817,9 @@ * Copy R from A to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), - $ LDVT ) + IF( N.GT.1 ) + $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, + $ VT( 2, 1 ), LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N
--- a/libcruft/lapack/dgetf2.f +++ b/libcruft/lapack/dgetf2.f @@ -1,9 +1,8 @@ SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -63,11 +62,13 @@ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - INTEGER J, JP + DOUBLE PRECISION SFMIN + INTEGER I, J, JP * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH INTEGER IDAMAX - EXTERNAL IDAMAX + EXTERNAL DLAMCH, IDAMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA @@ -97,6 +98,10 @@ IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. @@ -112,8 +117,15 @@ * * Compute elements J+1:M of J-th column. * - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF * ELSE IF( INFO.EQ.0 ) THEN *
--- a/libcruft/lapack/dgetrf.f +++ b/libcruft/lapack/dgetrf.f @@ -1,9 +1,8 @@ SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N
--- a/libcruft/lapack/dgetri.f +++ b/libcruft/lapack/dgetri.f @@ -1,9 +1,8 @@ SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N @@ -40,7 +39,7 @@ * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO=0, then WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dgetrs.f +++ b/libcruft/lapack/dgetrs.f @@ -1,9 +1,8 @@ SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANS
--- a/libcruft/lapack/dggbak.f +++ b/libcruft/lapack/dggbak.f @@ -1,10 +1,9 @@ SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE @@ -108,10 +107,15 @@ INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 - ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN + ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN + INFO = -4 + ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -5 + ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN - INFO = -6 + INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF
--- a/libcruft/lapack/dggbal.f +++ b/libcruft/lapack/dggbal.f @@ -1,10 +1,9 @@ SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOB @@ -88,7 +87,9 @@ * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * -* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) +* WORK (workspace) REAL array, dimension (lwork) +* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and +* at least 1 when JOB = 'N' or 'P'. * * INFO (output) INTEGER * = 0: successful exit @@ -141,20 +142,28 @@ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 + INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAL', -INFO ) RETURN END IF * - K = 1 - L = N -* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN + ILO = 1 + IHI = N + RETURN + END IF +* + IF( N.EQ.1 ) THEN + ILO = 1 + IHI = N + LSCALE( 1 ) = ONE + RSCALE( 1 ) = ONE + RETURN + END IF * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 @@ -166,14 +175,8 @@ RETURN END IF * - IF( K.EQ.L ) THEN - ILO = 1 - IHI = 1 - LSCALE( 1 ) = ONE - RSCALE( 1 ) = ONE - RETURN - END IF -* + K = 1 + L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * @@ -188,8 +191,8 @@ IF( L.NE.1 ) $ GO TO 30 * - RSCALE( 1 ) = 1 - LSCALE( 1 ) = 1 + RSCALE( 1 ) = ONE + LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE @@ -269,12 +272,17 @@ ILO = K IHI = L * + IF( LSAME( JOB, 'P' ) ) THEN + DO 195 I = ILO, IHI + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 195 CONTINUE + RETURN + END IF +* IF( ILO.EQ.IHI ) $ RETURN * - IF( LSAME( JOB, 'P' ) ) - $ RETURN -* * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 @@ -424,7 +432,7 @@ DO 360 I = ILO, IHI IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) - IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDA ) + IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
--- a/libcruft/lapack/dgghrd.f +++ b/libcruft/lapack/dgghrd.f @@ -1,10 +1,9 @@ SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -20,16 +19,32 @@ * * DGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are orthogonal, and ' means transpose. +* general matrix and B is upper triangular. The form of the +* generalized eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the orthogonal matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**T*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**T*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**T*x. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T +* +* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T +* +* If Q1 is the orthogonal matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then DGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -53,10 +68,11 @@ * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A 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 DGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. It is assumed that A 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 SGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) @@ -70,33 +86,28 @@ * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**T B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the orthogonal matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain an orthogonal matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the orthogonal matrix Q1, +* typically from the QR factorization of B. +* On exit, if COMPQ='I', the orthogonal matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the orthogonal matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain an orthogonal matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1. +* On exit, if COMPZ='I', the orthogonal matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z.
--- a/libcruft/lapack/dgtsv.f +++ b/libcruft/lapack/dgtsv.f @@ -1,9 +1,8 @@ SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS
--- a/libcruft/lapack/dgttrf.f +++ b/libcruft/lapack/dgttrf.f @@ -1,9 +1,8 @@ SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, N @@ -29,28 +28,31 @@ * ========= * * N (input) INTEGER -* The order of the matrix A. N >= 0. +* The order of the matrix A. * * DL (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, DL must contain the (n-1) subdiagonal elements of +* On entry, DL must contain the (n-1) sub-diagonal elements of * A. +* * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D must contain the diagonal elements of A. +* * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, DU must contain the (n-1) superdiagonal elements +* On entry, DU must contain the (n-1) super-diagonal elements * of A. +* * On exit, DU is overwritten by the (n-1) elements of the first -* superdiagonal of U. +* super-diagonal of U. * * DU2 (output) DOUBLE PRECISION array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the -* second superdiagonal of U. +* second super-diagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was @@ -60,14 +62,18 @@ * * INFO (output) INTEGER * = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION FACT, TEMP @@ -78,10 +84,6 @@ * .. External Subroutines .. EXTERNAL XERBLA * .. -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. * .. Executable Statements .. * INFO = 0 @@ -96,30 +98,25 @@ IF( N.EQ.0 ) $ RETURN * -* Initialize IPIV(i) = i +* Initialize IPIV(i) = i and DU2(I) = 0 * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE -* - DO 20 I = 1, N - 1 - IF( DL( I ).EQ.ZERO ) THEN -* -* Subdiagonal is zero, no elimination is required. + DO 20 I = 1, N - 2 + DU2( I ) = ZERO + 20 CONTINUE * - IF( D( I ).EQ.ZERO .AND. INFO.EQ.0 ) - $ INFO = I - IF( I.LT.N-1 ) - $ DU2( I ) = ZERO - ELSE IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN + DO 30 I = 1, N - 2 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * - FACT = DL( I ) / D( I ) - DL( I ) = FACT - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - IF( I.LT.N-1 ) - $ DU2( I ) = ZERO + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + DL( I ) = FACT + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + END IF ELSE * * Interchange rows I and I+1, eliminate DL(I) @@ -130,18 +127,40 @@ TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) - IF( I.LT.N-1 ) THEN - DU2( I ) = DU( I+1 ) - DU( I+1 ) = -FACT*DU( I+1 ) - END IF - IPIV( I ) = IPIV( I ) + 1 + DU2( I ) = DU( I+1 ) + DU( I+1 ) = -FACT*DU( I+1 ) + IPIV( I ) = I + 1 END IF - 20 CONTINUE - IF( D( N ).EQ.ZERO .AND. INFO.EQ.0 ) THEN - INFO = N - RETURN + 30 CONTINUE + IF( N.GT.1 ) THEN + I = N - 1 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + DL( I ) = FACT + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + END IF + ELSE + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + DL( I ) = FACT + TEMP = DU( I ) + DU( I ) = D( I+1 ) + D( I+1 ) = TEMP - FACT*D( I+1 ) + IPIV( I ) = I + 1 + END IF END IF * +* Check for a zero on the diagonal of U. +* + DO 40 I = 1, N + IF( D( I ).EQ.ZERO ) THEN + INFO = I + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE +* RETURN * * End of DGTTRF
--- a/libcruft/lapack/dgttrs.f +++ b/libcruft/lapack/dgttrs.f @@ -1,10 +1,9 @@ SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANS @@ -26,14 +25,14 @@ * Arguments * ========= * -* TRANS (input) CHARACTER -* Specifies the form of the system of equations: +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations. * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER -* The order of the matrix A. N >= 0. +* The order of the matrix A. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns @@ -48,10 +47,10 @@ * the LU factorization of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) -* The (n-1) elements of the first superdiagonal of U. +* The (n-1) elements of the first super-diagonal of U. * * DU2 (input) DOUBLE PRECISION array, dimension (N-2) -* The (n-2) elements of the second superdiagonal of U. +* The (n-2) elements of the second super-diagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was @@ -60,8 +59,8 @@ * required. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, B is overwritten by the solution matrix X. +* On entry, the matrix of right hand side vectors B. +* On exit, B is overwritten by the solution vectors X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). @@ -74,25 +73,24 @@ * * .. Local Scalars .. LOGICAL NOTRAN - INTEGER I, J - DOUBLE PRECISION TEMP + INTEGER ITRANS, J, JB, NB * .. * .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV * .. * .. External Subroutines .. - EXTERNAL XERBLA + EXTERNAL DGTTS2, XERBLA * .. * .. Intrinsic Functions .. - INTRINSIC MAX + INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN + NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) + IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. + $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 @@ -111,64 +109,30 @@ IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * - IF( NOTRAN ) THEN -* -* Solve A*X = B using the LU factorization of A, -* overwriting each right hand side vector with its solution. -* - DO 30 J = 1, NRHS -* -* Solve L*x = b. +* Decode TRANS * - DO 10 I = 1, N - 1 - IF( IPIV( I ).EQ.I ) THEN - B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) - ELSE - TEMP = B( I, J ) - B( I, J ) = B( I+1, J ) - B( I+1, J ) = TEMP - DL( I )*B( I, J ) - END IF - 10 CONTINUE + IF( NOTRAN ) THEN + ITRANS = 0 + ELSE + ITRANS = 1 + END IF * -* Solve U*x = b. +* Determine the number of right-hand sides to solve at a time. * - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / - $ D( N-1 ) - DO 20 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* - $ B( I+2, J ) ) / D( I ) - 20 CONTINUE - 30 CONTINUE + IF( NRHS.EQ.1 ) THEN + NB = 1 ELSE -* -* Solve A' * X = B. -* - DO 60 J = 1, NRHS -* -* Solve U'*x = b. + NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) ) + END IF * - B( 1, J ) = B( 1, J ) / D( 1 ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) - DO 40 I = 3, N - B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* - $ B( I-2, J ) ) / D( I ) - 40 CONTINUE -* -* Solve L'*x = b. -* - DO 50 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DL( I )*TEMP - B( I, J ) = TEMP - END IF - 50 CONTINUE - 60 CONTINUE + IF( NB.GE.NRHS ) THEN + CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) + ELSE + DO 10 J = 1, NRHS, NB + JB = MIN( NRHS-J+1, NB ) + CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), + $ LDB ) + 10 CONTINUE END IF * * End of DGTTRS
--- a/libcruft/lapack/dhgeqz.f +++ b/libcruft/lapack/dhgeqz.f @@ -1,56 +1,74 @@ - SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), - $ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ), - $ Z( LDZ, * ) + DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * -* DHGEQZ implements a single-/double-shift version of the QZ method for -* finding the generalized eigenvalues +* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the double-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a real matrix pair (A,B): * -* w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation +* A = Q1*H*Z1**T, B = Q1*T*Z1**T, +* +* as computed by DGGHRD. * -* det( A - w(i) B ) = 0 +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**T, T = Q*P*Z**T, +* +* where Q and Z are orthogonal matrices, P is an upper triangular +* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 +* diagonal blocks. * -* In addition, the pair A,B may be reduced to generalized Schur form: -* B is upper triangular, and A is block upper triangular, where the -* diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having -* complex generalized eigenvalues (see the description of the argument -* JOB.) +* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair +* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of +* eigenvalues. * -* If JOB='S', then the pair (A,B) is simultaneously reduced to Schur -* form by applying one orthogonal tranformation (usually called Q) on -* the left and another (usually called Z) on the right. The 2-by-2 -* upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks -* of A will be reduced to positive diagonal matrices. (I.e., -* if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and -* B(j+1,j+1) will be positive.) +* Additionally, the 2-by-2 upper triangular diagonal blocks of P +* corresponding to 2-by-2 blocks of S are reduced to positive diagonal +* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, +* P(j,j) > 0, and P(j+1,j+1) > 0. +* +* Optionally, the orthogonal matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* orthogonal matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced +* the matrix pair (A,B) to generalized upper Hessenberg form, then the +* output matrices Q1*Q and Z1*Z are the orthogonal factors from the +* generalized Schur factorization of (A,B): * -* If JOB='E', then at each iteration, the same transformations -* are computed, but they are only applied to those parts of A and B -* which are needed to compute ALPHAR, ALPHAI, and BETAR. -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, +* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is +* complex and beta real. +* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the +* generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* Real eigenvalues can be read directly from the generalized Schur +* form: +* alpha = S(i,i), beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -60,120 +78,104 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will -* not necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHAR, ALPHAI, and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Compute eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the transpose of -* the orthogonal tranformation that is applied to the -* left side of A and B to reduce them to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain an orthogonal matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the orthogonal -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain an orthogonal matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. * -* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to generalized Schur form. -* If JOB='E', then on exit A will have been destroyed. -* The diagonal blocks will be correct, but the off-diagonal -* portion will be meaningless. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). +* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper quasi-triangular +* matrix S from the generalized Schur factorization; +* 2-by-2 diagonal blocks (corresponding to complex conjugate +* pairs of eigenvalues) are returned in standard form, with +* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. +* If JOB = 'E', the diagonal blocks of H match those of S, but +* the rest of H is unspecified. * -* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. 2-by-2 blocks in B -* corresponding to 2-by-2 blocks in A will be reduced to -* positive diagonal form. (I.e., if A(j+1,j) is non-zero, -* then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be -* positive.) -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to Schur form. -* If JOB='E', then on exit B will have been destroyed. -* Elements corresponding to diagonal blocks of A will be -* correct, but the off-diagonal portion will be meaningless. +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization; +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S +* are reduced to positive diagonal form, i.e., if H(j+1,j) is +* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and +* T(j+1,j+1) > 0. +* If JOB = 'E', the diagonal blocks of T match those of P, but +* the rest of T is unspecified. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) -* ALPHAR(1:N) will be set to real parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. * * ALPHAI (output) DOUBLE PRECISION array, dimension (N) -* ALPHAI(1:N) will be set to imaginary parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0. -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. +* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +* positive, then the j-th and (j+1)-st eigenvalues are a +* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). * * BETA (output) DOUBLE PRECISION array, dimension (N) -* BETA(1:N) will be set to the (real) diagonal elements of B -* that would result from reducing A and B to Schur form and -* then further reducing them both to triangular form using -* unitary transformations s.t. the diagonal of B was -* non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. -* (Note that BETA(1:N) will always be non-negative, and no -* BETAI is necessary.) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the transpose of the orthogonal -* transformations which are applied to A and B on the left -* will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +* of left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the orthogonal transformations -* which are applied to A and B on the right will be applied -* to the array Z on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of +* right Schur vectors of (H,T), and if COMPZ = 'V', the +* orthogonal matrix of right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. * If COMPZ='V' or 'I', then LDZ >= N. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -187,13 +189,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -225,7 +226,7 @@ $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, - $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T, + $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 @@ -302,9 +303,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 @@ -340,8 +341,8 @@ SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) - ANORM = DLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK ) - BNORM = DLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK ) + ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -350,15 +351,15 @@ * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N @@ -366,9 +367,9 @@ 20 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps @@ -408,8 +409,8 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * @@ -417,14 +418,14 @@ * GO TO 80 ELSE - IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = ZERO + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = ZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO GO TO 70 END IF * @@ -432,36 +433,36 @@ * DO 60 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = ZERO + IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = ZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = ZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = ZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - TEMP = ABS( A( J, J-1 ) ) - TEMP2 = ABS( A( J, J ) ) + TEMP = ABS( H( J, J-1 ) ) + TEMP2 = ABS( H( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2* + IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2* $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. END IF * @@ -473,21 +474,21 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 40 JCH = J, ILAST - 1 - TEMP = A( JCH, JCH ) - CALL DLARTG( TEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = ZERO - CALL DROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL DROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + TEMP = H( JCH, JCH ) + CALL DLARTG( TEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = ZERO + CALL DROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL DROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. - IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 80 ELSE @@ -495,35 +496,35 @@ GO TO 110 END IF END IF - B( JCH+1, JCH+1 ) = ZERO + T( JCH+1, JCH+1 ) = ZERO 40 CONTINUE GO TO 70 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 50 JCH = J, ILAST - 1 - TEMP = B( JCH, JCH+1 ) - CALL DLARTG( TEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = ZERO + TEMP = T( JCH, JCH+1 ) + CALL DLARTG( TEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = ZERO IF( JCH.LT.ILASTM-1 ) - $ CALL DROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL DROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL DROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL DROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) - TEMP = A( JCH+1, JCH ) - CALL DLARTG( TEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = ZERO - CALL DROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL DROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + TEMP = H( JCH+1, JCH ) + CALL DLARTG( TEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = ZERO + CALL DROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL DROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -547,34 +548,34 @@ INFO = N + 1 GO TO 420 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 70 CONTINUE - TEMP = A( ILAST, ILAST ) - CALL DLARTG( TEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = ZERO - CALL DROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL DROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + TEMP = H( ILAST, ILAST ) + CALL DLARTG( TEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = ZERO + CALL DROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL DROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, * and BETA * 80 CONTINUE - IF( B( ILAST, ILAST ).LT.ZERO ) THEN + IF( T( ILAST, ILAST ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 90 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 90 CONTINUE ELSE - A( ILAST, ILAST ) = -A( ILAST, ILAST ) - B( ILAST, ILAST ) = -B( ILAST, ILAST ) + H( ILAST, ILAST ) = -H( ILAST, ILAST ) + T( ILAST, ILAST ) = -T( ILAST, ILAST ) END IF IF( ILZ ) THEN DO 100 J = 1, N @@ -582,9 +583,9 @@ 100 CONTINUE END IF END IF - ALPHAR( ILAST ) = A( ILAST, ILAST ) + ALPHAR( ILAST ) = H( ILAST, ILAST ) ALPHAI( ILAST ) = ZERO - BETA( ILAST ) = B( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -617,7 +618,7 @@ * Compute single shifts. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.EQ.IITER ) THEN @@ -625,10 +626,10 @@ * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * - IF( ( DBLE( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT. - $ ABS( B( ILAST-1, ILAST-1 ) ) ) THEN - ESHIFT = ESHIFT + A( ILAST-1, ILAST ) / - $ B( ILAST-1, ILAST-1 ) + IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. + $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN + ESHIFT = ESHIFT + H( ILAST-1, ILAST ) / + $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) ) END IF @@ -641,8 +642,8 @@ * bottom-right 2x2 block of A and B. The first eigenvalue * returned by DLAG2 is the Wilkinson shift (AEP p.512), * - CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) @@ -669,14 +670,14 @@ * DO 120 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - TEMP = ABS( S1*A( J, J-1 ) ) - TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) ) + TEMP = ABS( S1*H( J, J-1 ) ) + TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* + IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* $ TEMP2 )GO TO 130 120 CONTINUE * @@ -687,26 +688,26 @@ * * Initial Q * - TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART ) - TEMP2 = S1*A( ISTART+1, ISTART ) + TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART ) + TEMP2 = S1*H( ISTART+1, ISTART ) CALL DLARTG( TEMP, TEMP2, C, S, TEMPR ) * * Sweep * DO 190 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - TEMP = A( J, J-1 ) - CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO END IF * DO 140 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 140 CONTINUE IF( ILQ ) THEN DO 150 JR = 1, N @@ -716,19 +717,19 @@ 150 CONTINUE END IF * - TEMP = B( J+1, J+1 ) - CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 160 JR = IFRSTM, MIN( J+2, ILAST ) - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 160 CONTINUE DO 170 JR = IFRSTM, J - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 170 CONTINUE IF( ILZ ) THEN DO 180 JR = 1, N @@ -759,8 +760,8 @@ * B = ( ) with B11 non-negative. * ( 0 B22 ) * - CALL DLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ), - $ B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) + CALL DLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ), + $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) * IF( B11.LT.ZERO ) THEN CR = -CR @@ -769,17 +770,17 @@ B22 = -B22 END IF * - CALL DROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA, - $ A( ILAST, ILAST-1 ), LDA, CL, SL ) - CALL DROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1, - $ A( IFRSTM, ILAST ), 1, CR, SR ) + CALL DROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH, + $ H( ILAST, ILAST-1 ), LDH, CL, SL ) + CALL DROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1, + $ H( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILAST.LT.ILASTM ) - $ CALL DROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB, - $ B( ILAST, ILAST+1 ), LDA, CL, SL ) + $ CALL DROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT, + $ T( ILAST, ILAST+1 ), LDH, CL, SL ) IF( IFRSTM.LT.ILAST-1 ) - $ CALL DROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1, - $ B( IFRSTM, ILAST ), 1, CR, SR ) + $ CALL DROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1, + $ T( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILQ ) $ CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, @@ -788,17 +789,17 @@ $ CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, $ SR ) * - B( ILAST-1, ILAST-1 ) = B11 - B( ILAST-1, ILAST ) = ZERO - B( ILAST, ILAST-1 ) = ZERO - B( ILAST, ILAST ) = B22 + T( ILAST-1, ILAST-1 ) = B11 + T( ILAST-1, ILAST ) = ZERO + T( ILAST, ILAST-1 ) = ZERO + T( ILAST, ILAST ) = B22 * * If B22 is negative, negate column ILAST * IF( B22.LT.ZERO ) THEN DO 210 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 210 CONTINUE * IF( ILZ ) THEN @@ -812,8 +813,8 @@ * * Recompute shift * - CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ TEMP, WR, TEMP2, WI ) * * If standardization has perturbed the shift onto real line, @@ -825,10 +826,10 @@ * * Do EISPACK (QZVAL) computation of alpha and beta * - A11 = A( ILAST-1, ILAST-1 ) - A21 = A( ILAST, ILAST-1 ) - A12 = A( ILAST-1, ILAST ) - A22 = A( ILAST, ILAST ) + A11 = H( ILAST-1, ILAST-1 ) + A21 = H( ILAST, ILAST-1 ) + A12 = H( ILAST-1, ILAST ) + A22 = H( ILAST, ILAST ) * * Compute complex Givens rotation on right * (Assume some element of C = (sA - wB) > unfl ) @@ -845,10 +846,10 @@ * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN - T = DLAPY3( C12, C11R, C11I ) - CZ = C12 / T - SZR = -C11R / T - SZI = -C11I / T + T1 = DLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 ELSE CZ = DLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN @@ -858,10 +859,10 @@ ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ - T = DLAPY2( CZ, C21 ) - CZ = CZ / T - SZR = -C21*TEMPR / T - SZI = C21*TEMPI / T + T1 = DLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 END IF END IF * @@ -895,10 +896,10 @@ SQI = TEMPI*A2R - TEMPR*A2I END IF END IF - T = DLAPY3( CQ, SQR, SQI ) - CQ = CQ / T - SQR = SQR / T - SQI = SQI / T + T1 = DLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = SQI / T1 * * Compute diagonal elements of QBZ * @@ -950,26 +951,26 @@ * * We assume that the block is at least 3x3 * - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST ) - AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L @@ -991,27 +992,27 @@ * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN - V( 1 ) = A( J, J-1 ) - V( 2 ) = A( J+1, J-1 ) - V( 3 ) = A( J+2, J-1 ) + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) * - CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU ) + CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE - A( J+1, J-1 ) = ZERO - A( J+2, J-1 ) = ZERO + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM - TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )* - $ A( J+2, JC ) ) - A( J, JC ) = A( J, JC ) - TEMP - A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 ) - A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )* - $ B( J+2, JC ) ) - B( J, JC ) = B( J, JC ) - TEMP2 - B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 ) - B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 ) + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N @@ -1028,27 +1029,27 @@ * Swap rows to pivot * ILPIVT = .FALSE. - TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) ) - TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) ) + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN - W11 = B( J+1, J+1 ) - W21 = B( J+2, J+1 ) - W12 = B( J+1, J+2 ) - W22 = B( J+2, J+2 ) - U1 = B( J+1, J ) - U2 = B( J+2, J ) + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) ELSE - W21 = B( J+1, J+1 ) - W11 = B( J+2, J+1 ) - W22 = B( J+1, J+2 ) - W12 = B( J+2, J+2 ) - U2 = B( J+1, J ) - U1 = B( J+2, J ) + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) END IF * * Swap columns if nec. @@ -1098,9 +1099,9 @@ * * Compute Householder Vector * - T = SQRT( SCALE**2+U1**2+U2**2 ) - TAU = ONE + SCALE / T - VS = -ONE / ( SCALE+T ) + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 @@ -1108,18 +1109,18 @@ * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )* - $ A( JR, J+2 ) ) - A( JR, J ) = A( JR, J ) - TEMP - A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 ) - A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )* - $ B( JR, J+2 ) ) - B( JR, J ) = B( JR, J ) - TEMP - B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 ) - B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N @@ -1130,8 +1131,8 @@ Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF - B( J+1, J ) = ZERO - B( J+2, J ) = ZERO + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations @@ -1139,17 +1140,17 @@ * Rotations from the left * J = ILAST - 1 - TEMP = A( J, J-1 ) - CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N @@ -1161,19 +1162,19 @@ * * Rotations from the right. * - TEMP = B( J+1, J+1 ) - CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N @@ -1196,7 +1197,6 @@ * * Drop-through = non-convergence * - 370 CONTINUE INFO = ILAST GO TO 420 * @@ -1207,15 +1207,15 @@ * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N @@ -1223,9 +1223,9 @@ 400 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination
--- a/libcruft/lapack/dhseqr.f +++ b/libcruft/lapack/dhseqr.f @@ -1,160 +1,276 @@ SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- 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 - INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. +* Purpose +* ======= * -* Purpose -* ======= +* DHSEQR computes the eigenvalues of a Hessenberg matrix H +* and, optionally, the matrices T and Z from the Schur decomposition +* H = Z T Z**T, where T is an upper quasi-triangular matrix (the +* Schur form), and Z is the orthogonal matrix of Schur vectors. +* +* Optionally Z may be postmultiplied into an input orthogonal +* 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 orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. * -* DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H -* and, optionally, the matrices T and Z from the Schur decomposition -* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur -* form), and Z is the orthogonal matrix of Schur vectors. +* 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 orthogonal matrix Q on entry, and +* the product Q*Z is returned. * -* Optionally Z may be postmultiplied into an input orthogonal 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 orthogonal -* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +* 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 DGEBAL, and then passed to DGEHRD +* when the matrix output by DGEBAL 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. * -* Arguments -* ========= +* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and JOB = 'S', then H contains the +* upper quasi-triangular matrix T from the Schur decomposition +* (the Schur form); 2-by-2 diagonal blocks (corresponding to +* complex conjugate pairs of eigenvalues) are returned in +* standard form, with H(i,i) = H(i+1,i+1) and +* H(i+1,i)*H(i,i+1).LT.0. 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.) * -* JOB (input) CHARACTER*1 -* = 'E': compute eigenvalues only; -* = 'S': compute eigenvalues and the Schur form T. +* Unlike earlier versions of DHSEQR, 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. * -* 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 orthogonal matrix Q on entry, and -* the product Q*Z is returned. +* LDH (input) INTEGER +* The leading dimension of the array H. LDH .GE. max(1,N). * -* N (input) INTEGER -* The order of the matrix H. N >= 0. +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) +* The real and imaginary parts, respectively, of the computed +* eigenvalues. If two eigenvalues are computed as a complex +* conjugate pair, they are stored in consecutive elements of +* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and +* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in +* the same order as on the diagonal of the Schur form returned +* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 +* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +* WI(i+1) = -WI(i). +* +* Z (input/output) DOUBLE PRECISION 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 orthogonal 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 orthogonal matrix generated by DORGHR +* after the call to DGEHRD which formed the Hessenberg matrix +* H. (The output value of Z when INFO.GT.0 is given under +* the description of INFO below.) * -* 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 DGEBAL, and then passed to SGEHRD -* when the matrix output by DGEBAL is reduced to Hessenberg -* form. Otherwise ILO and IHI should be set to 1 and N -* respectively. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +* 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) DOUBLE PRECISION 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. * -* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) -* On entry, the upper Hessenberg matrix H. -* On exit, if JOB = 'S', H contains the upper quasi-triangular -* matrix T from the Schur decomposition (the Schur form); -* 2-by-2 diagonal blocks (corresponding to complex conjugate -* pairs of eigenvalues) are returned in standard form, with -* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', -* the contents of H are unspecified on exit. +* If LWORK = -1, then DHSEQR does a workspace query. +* In this case, DHSEQR 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. +* * -* LDH (input) INTEGER -* The leading dimension of the array H. LDH >= max(1,N). +* INFO (output) INTEGER +* = 0: successful exit +* .LT. 0: if INFO = -i, the i-th argument had an illegal +* value +* .GT. 0: if INFO = i, DHSEQR 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.) * -* WR (output) DOUBLE PRECISION array, dimension (N) -* WI (output) DOUBLE PRECISION array, dimension (N) -* The real and imaginary parts, respectively, of the computed -* eigenvalues. If two eigenvalues are computed as a complex -* conjugate pair, they are stored in consecutive elements of -* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and -* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the -* same order as on the diagonal of the Schur form returned in -* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 -* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and -* WI(i+1) = -WI(i). +* 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 an orthogonal matrix. The final +* value of H is upper Hessenberg and quasi-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 orthogonal 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 orthogonal matrix in (*) (regard- +* less of the value of JOB.) +* +* If INFO .GT. 0 and COMPZ = 'N', then Z is not +* accessed. * -* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -* If COMPZ = 'N': Z is not referenced. -* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z -* contains the orthogonal 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 Z contains Q*Z. -* Normally Q is the orthogonal matrix generated by DORGHR after -* the call to DGEHRD which formed the Hessenberg matrix H. +* ================================================================ +* Default values supplied by +* ILAENV(ISPEC,'DHSEQR',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 DLAHQR vs DLAQR0 crossover point. +* Default: 75. (Must be at least 11.) * -* LDZ (input) INTEGER -* The leading dimension of the array Z. -* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. +* 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 * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* 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 * -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). +* (+) By default some or all matrices of this order +* are passed to the implicit double shift routine +* DLAHQR 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. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* 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 * -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, DHSEQR failed to compute all of the -* eigenvalues in a total of 30*(IHI-ILO+1) iterations; -* elements 1:ilo-1 and i+1:n of WR and WI contain those -* eigenvalues which have been successfully computed. +* ================================================================ +* 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 +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== * -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) - DOUBLE PRECISION CONST - PARAMETER ( CONST = 1.5D+0 ) - INTEGER NSMAX, LDS - PARAMETER ( NSMAX = 15, LDS = NSMAX ) +* ==== NL allocates some local workspace to help small matrices +* . through a rare DLAHQR 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 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Arrays .. + DOUBLE PRECISION HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. + INTEGER I, KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ - INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L, - $ MAXB, NH, NR, NS, NV - DOUBLE PRECISION ABSW, OVFL, SMLNUM, TAU, TEMP, TST1, ULP, UNFL -* .. -* .. Local Arrays .. - DOUBLE PRECISION S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 ) * .. * .. External Functions .. + INTEGER ILAENV LOGICAL LSAME - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2 - EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2 + EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLACPY, DLAHQR, DLARFG, DLARFX, - $ DLASET, DSCAL, XERBLA + EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN + INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * -* Decode and test the input parameters +* ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DBLE( MAX( 1, N ) ) + LQUERY = LWORK.EQ.-1 * INFO = 0 - WORK( 1 ) = MAX( 1, N ) - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN @@ -167,301 +283,125 @@ 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 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF +* IF( INFO.NE.0 ) THEN +* +* ==== Quick return in case of invalid argument. ==== +* CALL XERBLA( 'DHSEQR', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF * -* Initialize Z, if necessary -* - IF( INITZ ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -* -* Store the eigenvalues isolated by DGEBAL. + ELSE IF( N.EQ.0 ) THEN * - DO 10 I = 1, ILO - 1 - WR( I ) = H( I, I ) - WI( I ) = ZERO - 10 CONTINUE - DO 20 I = IHI + 1, N - WR( I ) = H( I, I ) - WI( I ) = ZERO - 20 CONTINUE +* ==== Quick return in case N = 0; nothing to do. ==== * -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN - IF( ILO.EQ.IHI ) THEN - WR( ILO ) = H( ILO, ILO ) - WI( ILO ) = ZERO RETURN - END IF -* -* Set rows and columns ILO to IHI to zero below the first -* subdiagonal. * - DO 40 J = ILO, IHI - 2 - DO 30 I = J + 2, N - H( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - NH = IHI - ILO + 1 + ELSE IF( LQUERY ) THEN * -* Determine the order of the multi-shift QR algorithm to be used. +* ==== Quick return in case of a workspace query ==== * - NS = ILAENV( 4, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) - MAXB = ILAENV( 8, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) - IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN -* -* Use the standard double-shift algorithm + CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, WORK, LWORK, INFO ) +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== + WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) + RETURN * - CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, - $ IHI, Z, LDZ, INFO ) - RETURN - END IF - MAXB = MAX( 3, MAXB ) - NS = MIN( NS, MAXB, NSMAX ) -* -* Now 2 < NS <= MAXB < NH. + ELSE * -* Set machine-dependent constants for the stopping criterion. -* If norm(H) <= sqrt(OVFL), overflow should not occur. -* - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( NH / ULP ) -* -* I1 and I2 are the indices of the first row and last column of H -* to which transformations must be applied. If eigenvalues only are -* being computed, I1 and I2 are set inside the main loop. +* ==== copy eigenvalues isolated by DGEBAL ==== * - IF( WANTT ) THEN - I1 = 1 - I2 = N - END IF -* -* ITN is the total number of multiple-shift QR iterations allowed. -* - ITN = 30*NH -* -* The main loop begins here. I is the loop index and decreases from -* IHI to ILO in steps of at most MAXB. Each iteration of the loop -* works with the active submatrix in rows and columns L to I. -* Eigenvalues I+1 to IHI have already converged. Either L = ILO or -* H(L,L-1) is negligible so that the matrix splits. + DO 10 I = 1, ILO - 1 + WR( I ) = H( I, I ) + WI( I ) = ZERO + 10 CONTINUE + DO 20 I = IHI + 1, N + WR( I ) = H( I, I ) + WI( I ) = ZERO + 20 CONTINUE * - I = IHI - 50 CONTINUE - L = ILO - IF( I.LT.ILO ) - $ GO TO 170 +* ==== Initialize Z, if requested ==== * -* Perform multiple-shift QR iterations on rows and columns ILO to I -* until a submatrix of order at most MAXB splits off at the bottom -* because a subdiagonal element has become negligible. -* - DO 150 ITS = 0, ITN -* -* Look for a single small subdiagonal element. + IF( INITZ ) + $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * - DO 60 K = I, L + 1, -1 - TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) - IF( TST1.EQ.ZERO ) - $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) - IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) - $ GO TO 70 - 60 CONTINUE - 70 CONTINUE - L = K - IF( L.GT.ILO ) THEN +* ==== Quick return if possible ==== * -* H(L,L-1) is negligible. -* - H( L, L-1 ) = ZERO + IF( ILO.EQ.IHI ) THEN + WR( ILO ) = H( ILO, ILO ) + WI( ILO ) = ZERO + RETURN END IF * -* Exit from loop if a submatrix of order <= MAXB has split off. +* ==== DLAHQR/DLAQR0 crossover point ==== * - IF( L.GE.I-MAXB+1 ) - $ GO TO 160 -* -* Now the active submatrix is in rows and columns L to I. If -* eigenvalues only are being computed, only the active submatrix -* need be transformed. + NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, + $ ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) * - IF( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF -* - IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN +* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== * -* Exceptional shifts. -* - DO 80 II = I - NS + 1, I - WR( II ) = CONST*( ABS( H( II, II-1 ) )+ - $ ABS( H( II, II ) ) ) - WI( II ) = ZERO - 80 CONTINUE + IF( N.GT.NMIN ) THEN + CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, WORK, LWORK, INFO ) ELSE * -* Use eigenvalues of trailing submatrix of order NS as shifts. +* ==== Small matrix ==== +* + CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, INFO ) +* + IF( INFO.GT.0 ) THEN +* +* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds +* . when DLAHQR fails. ==== +* + KBOT = INFO +* + IF( N.GE.NL ) THEN +* +* ==== Larger matrices have enough subdiagonal scratch +* . space to call DLAQR0 directly. ==== * - CALL DLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S, - $ LDS ) - CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS, - $ WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ, - $ IERR ) - IF( IERR.GT.0 ) THEN + CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, + $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) +* + ELSE +* +* ==== Tiny matrices don't have enough subdiagonal +* . scratch space to benefit from DLAQR0. Hence, +* . tiny matrices must be copied into a larger +* . array before calling DLAQR0. ==== * -* If DLAHQR failed to compute all NS eigenvalues, use the -* unconverged diagonal elements as the remaining shifts. -* - DO 90 II = 1, IERR - WR( I-NS+II ) = S( II, II ) - WI( I-NS+II ) = ZERO - 90 CONTINUE + CALL DLACPY( 'A', N, N, H, LDH, HL, NL ) + HL( N+1, N ) = ZERO + CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), + $ NL ) + CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, + $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) + IF( WANTT .OR. INFO.NE.0 ) + $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH ) + END IF END IF END IF * -* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) -* where G is the Hessenberg submatrix H(L:I,L:I) and w is -* the vector of shifts (stored in WR and WI). The result is -* stored in the local array V. -* - V( 1 ) = ONE - DO 100 II = 2, NS + 1 - V( II ) = ZERO - 100 CONTINUE - NV = 1 - DO 120 J = I - NS + 1, I - IF( WI( J ).GE.ZERO ) THEN - IF( WI( J ).EQ.ZERO ) THEN -* -* real shift -* - CALL DCOPY( NV+1, V, 1, VV, 1 ) - CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), - $ LDH, VV, 1, -WR( J ), V, 1 ) - NV = NV + 1 - ELSE IF( WI( J ).GT.ZERO ) THEN -* -* complex conjugate pair of shifts +* ==== Clear out the trash, if necessary. ==== * - CALL DCOPY( NV+1, V, 1, VV, 1 ) - CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), - $ LDH, V, 1, -TWO*WR( J ), VV, 1 ) - ITEMP = IDAMAX( NV+1, VV, 1 ) - TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM ) - CALL DSCAL( NV+1, TEMP, VV, 1 ) - ABSW = DLAPY2( WR( J ), WI( J ) ) - TEMP = ( TEMP*ABSW )*ABSW - CALL DGEMV( 'No transpose', NV+2, NV+1, ONE, - $ H( L, L ), LDH, VV, 1, TEMP, V, 1 ) - NV = NV + 2 - END IF -* -* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, -* reset it to the unit vector. -* - ITEMP = IDAMAX( NV, V, 1 ) - TEMP = ABS( V( ITEMP ) ) - IF( TEMP.EQ.ZERO ) THEN - V( 1 ) = ONE - DO 110 II = 2, NV - V( II ) = ZERO - 110 CONTINUE - ELSE - TEMP = MAX( TEMP, SMLNUM ) - CALL DSCAL( NV, ONE / TEMP, V, 1 ) - END IF - END IF - 120 CONTINUE -* -* Multiple-shift QR step -* - DO 140 K = L, I - 1 -* -* The first iteration of this loop determines a reflection G -* from the vector V and applies it from left and right to H, -* thus creating a nonzero bulge below the subdiagonal. + IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * -* Each subsequent iteration determines a reflection G to -* restore the Hessenberg form in the (K-1)th column, and thus -* chases the bulge one step toward the bottom of the active -* submatrix. NR is the order of G. -* - NR = MIN( NS+1, I-K+1 ) - IF( K.GT.L ) - $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) - CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) - IF( K.GT.L ) THEN - H( K, K-1 ) = V( 1 ) - DO 130 II = K + 1, I - H( II, K-1 ) = ZERO - 130 CONTINUE - END IF - V( 1 ) = ONE -* -* Apply G from the left to transform the rows of the matrix in -* columns K to I2. -* - CALL DLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH, - $ WORK ) -* -* Apply G from the right to transform the columns of the -* matrix in rows I1 to min(K+NR,I). -* - CALL DLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU, - $ H( I1, K ), LDH, WORK ) -* - IF( WANTZ ) THEN -* -* Accumulate transformations in the matrix Z +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== * - CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ, - $ WORK ) - END IF - 140 CONTINUE -* - 150 CONTINUE -* -* Failure to converge in remaining number of iterations -* - INFO = I - RETURN -* - 160 CONTINUE -* -* A submatrix of order <= MAXB in rows and columns L to I has split -* off. Use the double-shift QR algorithm to handle it. + WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) + END IF * - CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z, - $ LDZ, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Decrement number of remaining iterations, and return to start of -* the main loop with a new value of I. -* - ITN = ITN - ITS - I = L - 1 - GO TO 50 -* - 170 CONTINUE - WORK( 1 ) = MAX( 1, N ) - RETURN -* -* End of DHSEQR +* ==== End of DHSEQR ==== * END
--- a/libcruft/lapack/dlabad.f +++ b/libcruft/lapack/dlabad.f @@ -1,9 +1,8 @@ SUBROUTINE DLABAD( SMALL, LARGE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL
--- a/libcruft/lapack/dlabrd.f +++ b/libcruft/lapack/dlabrd.f @@ -1,10 +1,9 @@ SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB @@ -87,7 +86,7 @@ * The n-by-nb matrix Y required to update the unreduced part * of A. * -* LDY (output) INTEGER +* LDY (input) INTEGER * The leading dimension of the array Y. LDY >= N. * * Further Details
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlacn2.f @@ -0,0 +1,214 @@ + SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISGN( * ), ISAVE( 3 ) + DOUBLE PRECISION V( * ), X( * ) +* .. +* +* Purpose +* ======= +* +* DLACN2 estimates the 1-norm of a square, real matrix A. +* Reverse communication is used for evaluating matrix-vector products. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix. N >= 1. +* +* V (workspace) DOUBLE PRECISION array, dimension (N) +* On the final return, V = A*W, where EST = norm(V)/norm(W) +* (W is not returned). +* +* X (input/output) DOUBLE PRECISION array, dimension (N) +* On an intermediate return, X should be overwritten by +* A * X, if KASE=1, +* A' * X, if KASE=2, +* and DLACN2 must be re-called with all the other parameters +* unchanged. +* +* ISGN (workspace) INTEGER array, dimension (N) +* +* EST (input/output) DOUBLE PRECISION +* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be +* unchanged from the previous call to DLACN2. +* On exit, EST is an estimate (a lower bound) for norm(A). +* +* KASE (input/output) INTEGER +* On the initial call to DLACN2, KASE should be 0. +* On an intermediate return, KASE will be 1 or 2, indicating +* whether X should be overwritten by A * X or A' * X. +* On the final return from DLACN2, KASE will again be 0. +* +* ISAVE (input/output) INTEGER array, dimension (3) +* ISAVE is used to save variables between calls to DLACN2 +* +* Further Details +* ======= ======= +* +* Contributed by Nick Higham, University of Manchester. +* Originally named SONEST, dated March 16, 1988. +* +* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of +* a real or complex matrix, with applications to condition estimation", +* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. +* +* This is a thread safe version of DLACON, which uses the array ISAVE +* in place of a SAVE statement, as follows: +* +* DLACON DLACN2 +* JUMP ISAVE(1) +* J ISAVE(2) +* ITER ISAVE(3) +* +* ===================================================================== +* +* .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, JLAST + DOUBLE PRECISION ALTSGN, ESTOLD, TEMP +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM + EXTERNAL IDAMAX, DASUM +* .. +* .. External Subroutines .. + EXTERNAL DCOPY +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, NINT, SIGN +* .. +* .. Executable Statements .. +* + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = ONE / DBLE( N ) + 10 CONTINUE + KASE = 1 + ISAVE( 1 ) = 1 + RETURN + END IF +* + GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) +* +* ................ ENTRY (ISAVE( 1 ) = 1) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. +* + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) +* ... QUIT + GO TO 150 + END IF + EST = DASUM( N, X, 1 ) +* + DO 30 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 30 CONTINUE + KASE = 2 + ISAVE( 1 ) = 2 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 2) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. +* + 40 CONTINUE + ISAVE( 2 ) = IDAMAX( N, X, 1 ) + ISAVE( 3 ) = 2 +* +* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. +* + 50 CONTINUE + DO 60 I = 1, N + X( I ) = ZERO + 60 CONTINUE + X( ISAVE( 2 ) ) = ONE + KASE = 1 + ISAVE( 1 ) = 3 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 3) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 70 CONTINUE + CALL DCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DASUM( N, V, 1 ) + DO 80 I = 1, N + IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) + $ GO TO 90 + 80 CONTINUE +* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. + GO TO 120 +* + 90 CONTINUE +* TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 120 +* + DO 100 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 100 CONTINUE + KASE = 2 + ISAVE( 1 ) = 4 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 4) +* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. +* + 110 CONTINUE + JLAST = ISAVE( 2 ) + ISAVE( 2 ) = IDAMAX( N, X, 1 ) + IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. + $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN + ISAVE( 3 ) = ISAVE( 3 ) + 1 + GO TO 50 + END IF +* +* ITERATION COMPLETE. FINAL STAGE. +* + 120 CONTINUE + ALTSGN = ONE + DO 130 I = 1, N + X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) + ALTSGN = -ALTSGN + 130 CONTINUE + KASE = 1 + ISAVE( 1 ) = 5 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 5) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 140 CONTINUE + TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL DCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF +* + 150 CONTINUE + KASE = 0 + RETURN +* +* End of DLACN2 +* + END
--- a/libcruft/lapack/dlacon.f +++ b/libcruft/lapack/dlacon.f @@ -1,9 +1,8 @@ SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER KASE, N @@ -39,8 +38,10 @@ * * ISGN (workspace) INTEGER array, dimension (N) * -* EST (output) DOUBLE PRECISION -* An estimate (a lower bound) for norm(A). +* EST (input/output) DOUBLE PRECISION +* On entry with KASE = 1 or 2 and JUMP = 3, EST should be +* unchanged from the previous call to DLACON. +* On exit, EST is an estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to DLACON, KASE should be 0. @@ -118,7 +119,7 @@ RETURN * * ................ ENTRY (JUMP = 2) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE J = IDAMAX( N, X, 1 ) @@ -163,7 +164,7 @@ RETURN * * ................ ENTRY (JUMP = 4) -* X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. +* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = J
--- a/libcruft/lapack/dlacpy.f +++ b/libcruft/lapack/dlacpy.f @@ -1,9 +1,8 @@ SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dladiv.f +++ b/libcruft/lapack/dladiv.f @@ -1,9 +1,8 @@ SUBROUTINE DLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q
--- a/libcruft/lapack/dlae2.f +++ b/libcruft/lapack/dlae2.f @@ -1,9 +1,8 @@ SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2
--- a/libcruft/lapack/dlaev2.f +++ b/libcruft/lapack/dlaev2.f @@ -1,9 +1,8 @@ SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1
--- a/libcruft/lapack/dlaexc.f +++ b/libcruft/lapack/dlaexc.f @@ -1,10 +1,9 @@ SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL WANTQ
--- a/libcruft/lapack/dlag2.f +++ b/libcruft/lapack/dlag2.f @@ -1,10 +1,9 @@ SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER LDA, LDB
--- a/libcruft/lapack/dlahqr.f +++ b/libcruft/lapack/dlahqr.f @@ -1,42 +1,42 @@ SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * -* Purpose -* ======= +* Purpose +* ======= * -* DLAHQR is an auxiliary routine called by DHSEQR to update the -* eigenvalues and Schur decomposition already computed by DHSEQR, by -* dealing with the Hessenberg submatrix in rows and columns ILO to IHI. +* DLAHQR is an auxiliary routine called by DHSEQR to update the +* eigenvalues and Schur decomposition already computed by DHSEQR, by +* dealing with the Hessenberg submatrix in rows and columns ILO to +* IHI. * -* Arguments -* ========= +* Arguments +* ========= * -* WANTT (input) LOGICAL +* WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * -* WANTZ (input) LOGICAL +* WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * -* N (input) INTEGER +* N (input) INTEGER * The order of the matrix H. N >= 0. * -* ILO (input) INTEGER -* IHI (input) INTEGER +* ILO (input) INTEGER +* IHI (input) INTEGER * It is assumed that H is already upper quasi-triangular in * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless * ILO = 1). DLAHQR works primarily with the Hessenberg @@ -44,18 +44,20 @@ * transformations to all of H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * -* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. -* On exit, if WANTT is .TRUE., H is upper quasi-triangular in -* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in -* standard form. If WANTT is .FALSE., the contents of H are -* unspecified on exit. +* On exit, if INFO is zero and if WANTT is .TRUE., H is upper +* quasi-triangular in rows and columns ILO:IHI, with any +* 2-by-2 diagonal blocks in standard form. If INFO is zero +* and WANTT is .FALSE., the contents of H are unspecified on +* exit. The output state of H if INFO is nonzero is given +* below under the description of INFO. * -* LDH (input) INTEGER +* LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * -* WR (output) DOUBLE PRECISION array, dimension (N) -* WI (output) DOUBLE PRECISION array, dimension (N) +* WR (output) DOUBLE PRECISION array, dimension (N) +* WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues ILO to IHI are stored in the corresponding * elements of WR and WI. If two eigenvalues are computed as a @@ -67,62 +69,90 @@ * H(i:i+1,i:i+1) is a 2-by-2 diagonal block, * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). * -* ILOZ (input) INTEGER -* IHIZ (input) INTEGER +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * -* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by DHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * -* LDZ (input) INTEGER +* LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * -* INFO (output) INTEGER -* = 0: successful exit -* > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI -* in a total of 30*(IHI-ILO+1) iterations; if INFO = i, -* elements i+1:ihi of WR and WI contain those eigenvalues -* which have been successfully computed. +* INFO (output) INTEGER +* = 0: successful exit +* .GT. 0: If INFO = i, DLAHQR failed to compute all the +* eigenvalues ILO to IHI in a total of 30 iterations +* per eigenvalue; elements i+1:ihi of WR and WI +* contain those eigenvalues which have been +* successfully computed. +* +* If INFO .GT. 0 and WANTT is .FALSE., then on exit, +* the remaining unconverged eigenvalues are the +* eigenvalues of the upper Hessenberg matrix rows +* and columns ILO thorugh INFO of the final, output +* value of H. * -* Further Details -* =============== +* If INFO .GT. 0 and WANTT is .TRUE., then on exit +* (*) (initial value of H)*U = U*(final value of H) +* where U is an orthognal matrix. The final +* value of H is upper Hessenberg and triangular in +* rows and columns INFO+1 through IHI. * -* 2-96 Based on modifications by +* If INFO .GT. 0 and WANTZ is .TRUE., then on exit +* (final value of Z) = (initial value of Z)*U +* where U is the orthogonal matrix in (*) +* (regardless of the value of WANTT.) +* +* Further Details +* =============== +* +* 02-96 Based on modifications by * David Day, Sandia National Laboratory, USA * -* ===================================================================== +* 12-04 Further modifications by +* Ralph Byers, University of Kansas, USA +* +* This is a modified version of DLAHQR from LAPACK version 3.0. +* It is (1) more robust against overflow and underflow and +* (2) adopts the more conservative Ahues & Tisseur stopping +* criterion (LAWN 122, 1997). +* +* ========================================================= * * .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D0 ) + INTEGER ITMAX + PARAMETER ( ITMAX = 30 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 ) DOUBLE PRECISION DAT1, DAT2 - PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) + PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 ) * .. * .. Local Scalars .. - INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ - DOUBLE PRECISION AVE, CS, DISC, H00, H10, H11, H12, H21, H22, - $ H33, H33S, H43H34, H44, H44S, OVFL, S, SMLNUM, - $ SN, SUM, T1, T2, T3, TST1, ULP, UNFL, V1, V2, - $ V3 + DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, + $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, + $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, + $ ULP, V2, V3 + INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ * .. * .. Local Arrays .. - DOUBLE PRECISION V( 3 ), WORK( 1 ) + DOUBLE PRECISION V( 3 ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLANV2, DLARFG, DROT + EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SIGN, SQRT + INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * @@ -138,17 +168,24 @@ RETURN END IF * +* ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO +* NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. -* If norm(H) <= sqrt(OVFL), overflow should not occur. * - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( NH / ULP ) + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are @@ -159,10 +196,6 @@ I2 = N END IF * -* ITN is the total number of QR iterations allowed. -* - ITN = 30*NH -* * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works * with the active submatrix in rows and columns L to I. @@ -170,27 +203,46 @@ * H(L,L-1) is negligible so that the matrix splits. * I = IHI - 10 CONTINUE + 20 CONTINUE L = ILO IF( I.LT.ILO ) - $ GO TO 150 + $ GO TO 160 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * - DO 130 ITS = 0, ITN + DO 140 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * - DO 20 K = I, L + 1, -1 - TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) - IF( TST1.EQ.ZERO ) - $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) - IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) - $ GO TO 30 - 20 CONTINUE + DO 30 K = I, L + 1, -1 + IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) + $ GO TO 40 + TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) + IF( TST.EQ.ZERO ) THEN + IF( K-2.GE.ILO ) + $ TST = TST + ABS( H( K-1, K-2 ) ) + IF( K+1.LE.IHI ) + $ TST = TST + ABS( H( K+1, K ) ) + END IF +* ==== The following is a conservative small subdiagonal +* . deflation criterion due to Ahues & Tisseur (LAWN 122, +* . 1997). It has better mathematical foundation and +* . improves accuracy in some cases. ==== + IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN + AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) + BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) + AA = MAX( ABS( H( K, K ) ), + $ ABS( H( K-1, K-1 )-H( K, K ) ) ) + BB = MIN( ABS( H( K, K ) ), + $ ABS( H( K-1, K-1 )-H( K, K ) ) ) + S = AA + AB + IF( BA*( AB / S ).LE.MAX( SMLNUM, + $ ULP*( BB*( AA / S ) ) ) )GO TO 40 + END IF 30 CONTINUE + 40 CONTINUE L = K IF( L.GT.ILO ) THEN * @@ -202,7 +254,7 @@ * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) - $ GO TO 140 + $ GO TO 150 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix @@ -217,74 +269,90 @@ * * Exceptional shift. * - S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) - H44 = DAT1*S + H( I, I ) - H33 = H44 - H43H34 = DAT2*S*S + H11 = DAT1*S + H( I, I ) + H12 = DAT2*S + H21 = S + H22 = H11 ELSE * * Prepare to use Francis' double shift * (i.e. 2nd degree generalized Rayleigh quotient) * - H44 = H( I, I ) - H33 = H( I-1, I-1 ) - H43H34 = H( I, I-1 )*H( I-1, I ) - S = H( I-1, I-2 )*H( I-1, I-2 ) - DISC = ( H33-H44 )*HALF - DISC = DISC*DISC + H43H34 - IF( DISC.GT.ZERO ) THEN -* -* Real roots: use Wilkinson's shift twice + H11 = H( I-1, I-1 ) + H21 = H( I, I-1 ) + H12 = H( I-1, I ) + H22 = H( I, I ) + END IF + S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) + IF( S.EQ.ZERO ) THEN + RT1R = ZERO + RT1I = ZERO + RT2R = ZERO + RT2I = ZERO + ELSE + H11 = H11 / S + H21 = H21 / S + H12 = H12 / S + H22 = H22 / S + TR = ( H11+H22 ) / TWO + DET = ( H11-TR )*( H22-TR ) - H12*H21 + RTDISC = SQRT( ABS( DET ) ) + IF( DET.GE.ZERO ) THEN * - DISC = SQRT( DISC ) - AVE = HALF*( H33+H44 ) - IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN - H33 = H33*H44 - H43H34 - H44 = H33 / ( SIGN( DISC, AVE )+AVE ) +* ==== complex conjugate shifts ==== +* + RT1R = TR*S + RT2R = RT1R + RT1I = RTDISC*S + RT2I = -RT1I + ELSE +* +* ==== real shifts (use only one of them) ==== +* + RT1R = TR + RTDISC + RT2R = TR - RTDISC + IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN + RT1R = RT1R*S + RT2R = RT1R ELSE - H44 = SIGN( DISC, AVE ) + AVE + RT2R = RT2R*S + RT1R = RT2R END IF - H33 = H44 - H43H34 = ZERO + RT1I = ZERO + RT2I = ZERO END IF END IF * * Look for two consecutive small subdiagonal elements. * - DO 40 M = I - 2, L, -1 + DO 50 M = I - 2, L, -1 * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) -* negligible. +* negligible. (The following uses scaling to avoid +* overflows and most underflows.) * - H11 = H( M, M ) - H22 = H( M+1, M+1 ) - H21 = H( M+1, M ) - H12 = H( M, M+1 ) - H44S = H44 - H11 - H33S = H33 - H11 - V1 = ( H33S*H44S-H43H34 ) / H21 + H12 - V2 = H22 - H11 - H33S - H44S - V3 = H( M+2, M+1 ) - S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) - V1 = V1 / S - V2 = V2 / S - V3 = V3 / S - V( 1 ) = V1 - V( 2 ) = V2 - V( 3 ) = V3 + H21S = H( M+1, M ) + S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) + H21S = H( M+1, M ) / S + V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* + $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) + V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) + V( 3 ) = H21S*H( M+2, M+1 ) + S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) + V( 1 ) = V( 1 ) / S + V( 2 ) = V( 2 ) / S + V( 3 ) = V( 3 ) / S IF( M.EQ.L ) - $ GO TO 50 - H00 = H( M-1, M-1 ) - H10 = H( M, M-1 ) - TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) ) - IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 ) - $ GO TO 50 - 40 CONTINUE + $ GO TO 60 + IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. + $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, + $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 50 CONTINUE + 60 CONTINUE * * Double-shift QR step * - DO 120 K = M, I - 1 + DO 130 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, @@ -316,75 +384,75 @@ * Apply G from the left to transform the rows of the matrix * in columns K to I2. * - DO 60 J = K, I2 + DO 70 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 - 60 CONTINUE + 70 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * - DO 70 J = I1, MIN( K+3, I ) + DO 80 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 - 70 CONTINUE + 80 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * - DO 80 J = ILOZ, IHIZ + DO 90 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 - 80 CONTINUE + 90 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * - DO 90 J = K, I2 + DO 100 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 - 90 CONTINUE + 100 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * - DO 100 J = I1, I + DO 110 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 - 100 CONTINUE + 110 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * - DO 110 J = ILOZ, IHIZ + DO 120 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 - 110 CONTINUE + 120 CONTINUE END IF END IF - 120 CONTINUE + 130 CONTINUE * - 130 CONTINUE + 140 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * - 140 CONTINUE + 150 CONTINUE * IF( L.EQ.I ) THEN * @@ -420,14 +488,12 @@ END IF END IF * -* Decrement number of remaining iterations, and return to start of -* the main loop with new value of I. +* return to start of the main loop with new value of I. * - ITN = ITN - ITS I = L - 1 - GO TO 10 + GO TO 20 * - 150 CONTINUE + 160 CONTINUE RETURN * * End of DLAHQR
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlahr2.f @@ -0,0 +1,238 @@ + SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* Purpose +* ======= +* +* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) +* matrix A so that elements below the k-th subdiagonal are zero. The +* reduction is performed by an orthogonal similarity transformation +* Q' * A * Q. The routine returns the matrices V and T which determine +* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. +* +* This is an auxiliary routine called by DGEHRD. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. +* +* K (input) INTEGER +* The offset for the reduction. Elements below the k-th +* subdiagonal in the first NB columns are reduced to zero. +* K < N. +* +* NB (input) INTEGER +* The number of columns to be reduced. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) +* On entry, the n-by-(n-k+1) general matrix A. +* On exit, the elements on and above the k-th subdiagonal in +* the first NB columns are overwritten with the corresponding +* elements of the reduced matrix; the elements below the k-th +* subdiagonal, with the array TAU, represent the matrix Q as a +* product of elementary reflectors. The other columns of A are +* unchanged. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (output) DOUBLE PRECISION array, dimension (NB) +* The scalar factors of the elementary reflectors. See Further +* Details. +* +* T (output) DOUBLE PRECISION array, dimension (LDT,NB) +* The upper triangular matrix T. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= NB. +* +* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) +* The n-by-nb matrix Y. +* +* LDY (input) INTEGER +* The leading dimension of the array Y. LDY >= N. +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of nb elementary reflectors +* +* Q = H(1) H(2) . . . H(nb). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a real scalar, and v is a real vector with +* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in +* A(i+k+1:n,i), and tau in TAU(i). +* +* The elements of the vectors v together form the (n-k+1)-by-nb matrix +* V which is needed, with T and Y, to apply the transformation to the +* unreduced part of the matrix, using an update of the form: +* A := (I - V*T*V') * (A - Y*V'). +* +* The contents of A on exit are illustrated by the following example +* with n = 7, k = 3 and nb = 2: +* +* ( a a a a a ) +* ( a a a a a ) +* ( a a a a a ) +* ( h h a a a ) +* ( v1 h a a a ) +* ( v1 v2 a a a ) +* ( v1 v2 a a a ) +* +* where a denotes an element of the original matrix A, h denotes a +* modified element of the upper Hessenberg matrix H, and vi denotes an +* element of the vector defining H(i). +* +* This file is a slight modification of LAPACK-3.0's DLAHRD +* incorporating improvements proposed by Quintana-Orti and Van de +* Gejin. Note that the entries of A(1:K,2:NB) differ from those +* returned by the original LAPACK routine. This function is +* not backward compatible with LAPACK3.0. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION EI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, + $ DLARFG, DSCAL, DTRMM, DTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V' +* + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) +* +* Apply I - V * T' * V' to this column (call it b) from the +* left, using the last column of T as workspace +* +* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) +* ( V2 ) ( b2 ) +* +* where V1 is unit lower triangular +* +* w := V1' * b1 +* + CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL DTRMV( 'Lower', 'Transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2'*b2 +* + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) +* +* w := T'*w +* + CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL DTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(I) to annihilate +* A(K+I+1:N,I) +* + CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(K+1:N,I) +* + CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) +* +* Compute T(1:I,I) +* + CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* +* Compute Y(1:K,1:NB) +* + CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) +* + RETURN +* +* End of DLAHR2 +* + END
--- a/libcruft/lapack/dlahrd.f +++ b/libcruft/lapack/dlahrd.f @@ -1,9 +1,8 @@ SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -22,7 +21,9 @@ * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * -* This is an auxiliary routine called by DGEHRD. +* This is an OBSOLETE auxiliary routine. +* This routine will be 'deprecated' in a future release. +* Please use the new routine DLAHR2 instead. * * Arguments * =========
--- a/libcruft/lapack/dlaln2.f +++ b/libcruft/lapack/dlaln2.f @@ -1,10 +1,9 @@ SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL LTRANS
--- a/libcruft/lapack/dlamc1.f +++ b/libcruft/lapack/dlamc1.f @@ -1,9 +1,8 @@ SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL IEEE1, RND @@ -68,7 +67,6 @@ * .. Executable Statements .. * IF( FIRST ) THEN - FIRST = .FALSE. ONE = 1 * * LBETA, LIEEE1, LT and LRND are the local values of BETA, @@ -177,6 +175,7 @@ T = LT RND = LRND IEEE1 = LIEEE1 + FIRST = .FALSE. RETURN * * End of DLAMC1
--- a/libcruft/lapack/dlamc2.f +++ b/libcruft/lapack/dlamc2.f @@ -1,9 +1,8 @@ SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL RND @@ -90,7 +89,6 @@ * .. Executable Statements .. * IF( FIRST ) THEN - FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 @@ -204,6 +202,7 @@ * ( A guess; no known machine ) IWARN = .TRUE. END IF + FIRST = .FALSE. *** * Comment out this if block if EMIN is ok IF( IWARN ) THEN
--- a/libcruft/lapack/dlamc3.f +++ b/libcruft/lapack/dlamc3.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B @@ -19,7 +18,8 @@ * Arguments * ========= * -* A, B (input) DOUBLE PRECISION +* A (input) DOUBLE PRECISION +* B (input) DOUBLE PRECISION * The values A and B. * * =====================================================================
--- a/libcruft/lapack/dlamc4.f +++ b/libcruft/lapack/dlamc4.f @@ -1,9 +1,8 @@ SUBROUTINE DLAMC4( EMIN, START, BASE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER BASE, EMIN @@ -18,7 +17,7 @@ * Arguments * ========= * -* EMIN (output) EMIN +* EMIN (output) INTEGER * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered.
--- a/libcruft/lapack/dlamc5.f +++ b/libcruft/lapack/dlamc5.f @@ -1,9 +1,8 @@ SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL IEEE
--- a/libcruft/lapack/dlamch.f +++ b/libcruft/lapack/dlamch.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER CMACH @@ -72,7 +71,6 @@ * .. Executable Statements .. * IF( FIRST ) THEN - FIRST = .FALSE. CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT @@ -120,6 +118,7 @@ END IF * DLAMCH = RMACH + FIRST = .FALSE. RETURN * * End of DLAMCH
--- a/libcruft/lapack/dlange.f +++ b/libcruft/lapack/dlange.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER NORM @@ -36,7 +35,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -59,7 +58,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. *
--- a/libcruft/lapack/dlanhs.f +++ b/libcruft/lapack/dlanhs.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER NORM @@ -36,7 +35,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -56,7 +55,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. *
--- a/libcruft/lapack/dlanst.f +++ b/libcruft/lapack/dlanst.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER NORM @@ -36,7 +35,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * =========
--- a/libcruft/lapack/dlansy.f +++ b/libcruft/lapack/dlansy.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER NORM, UPLO @@ -36,7 +35,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -67,7 +66,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. *
--- a/libcruft/lapack/dlantr.f +++ b/libcruft/lapack/dlantr.f @@ -1,10 +1,9 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO @@ -37,7 +36,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -79,7 +78,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. *
--- a/libcruft/lapack/dlanv2.f +++ b/libcruft/lapack/dlanv2.f @@ -1,9 +1,8 @@ SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
--- a/libcruft/lapack/dlapy2.f +++ b/libcruft/lapack/dlapy2.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y
--- a/libcruft/lapack/dlapy3.f +++ b/libcruft/lapack/dlapy3.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z @@ -42,7 +41,10 @@ ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN - DLAPY3 = ZERO +* W can be zero for max(0,nan,0) +* adding all three entries together will make sure +* NaN will not disappear. + DLAPY3 = XABS + YABS + ZABS ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 )
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlaqr0.f @@ -0,0 +1,642 @@ + SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* DLAQR0 computes the eigenvalues of a Hessenberg matrix H +* and, optionally, the matrices T and Z from the Schur decomposition +* H = Z T Z**T, where T is an upper quasi-triangular matrix (the +* Schur form), and Z is the orthogonal matrix of Schur vectors. +* +* Optionally Z may be postmultiplied into an input orthogonal +* 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 orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +* +* Arguments +* ========= +* +* WANTT (input) LOGICAL +* = .TRUE. : the full Schur form T is required; +* = .FALSE.: only eigenvalues are required. +* +* WANTZ (input) LOGICAL +* = .TRUE. : the matrix of Schur vectors Z is required; +* = .FALSE.: Schur vectors are not required. +* +* 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 and, if ILO.GT.1, +* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +* previous call to DGEBAL, and then passed to DGEHRD when the +* matrix output by DGEBAL 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) DOUBLE PRECISION array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and WANTT is .TRUE., then H contains +* the upper quasi-triangular matrix T from the Schur +* decomposition (the Schur form); 2-by-2 diagonal blocks +* (corresponding to complex conjugate pairs of eigenvalues) +* are returned in standard form, with H(i,i) = H(i+1,i+1) +* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is +* .FALSE., then 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.) +* +* This subroutine may explicitly set 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). +* +* WR (output) DOUBLE PRECISION array, dimension (IHI) +* WI (output) DOUBLE PRECISION array, dimension (IHI) +* The real and imaginary parts, respectively, of the computed +* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) +* and WI(ILO:IHI). If two eigenvalues are computed as a +* complex conjugate pair, they are stored in consecutive +* elements of WR and WI, say the i-th and (i+1)th, with +* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then +* the eigenvalues are stored in the same order as on the +* diagonal of the Schur form returned in H, with +* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +* WI(i+1) = -WI(i). +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. +* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) +* If WANTZ is .FALSE., then Z is not referenced. +* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +* (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 WANTZ is .TRUE. +* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK +* On exit, if LWORK = -1, 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 DLAQR0 does a workspace query. +* In this case, DLAQR0 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 +* .GT. 0: if INFO = i, DLAQR0 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 WANT is .FALSE., 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 WANTT is .TRUE., then on exit +* +* (*) (initial value of H)*U = U*(final value of H) +* +* where U is an orthogonal matrix. The final +* value of H is upper Hessenberg and quasi-triangular +* in rows and columns INFO+1 through IHI. +* +* If INFO .GT. 0 and WANTZ is .TRUE., then on exit +* +* (final value of Z(ILO:IHI,ILOZ:IHIZ) +* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +* +* where U is the orthogonal matrix in (*) (regard- +* less of the value of WANTT.) +* +* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +* accessed. +* +* +* ================================================================ +* 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 +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by increasing the size of the +* . deflation window after KEXNW iterations. ===== +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use DLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to DLAQR3 ==== +* + CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 80 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 90 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if DLAQR3 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . DLAQR3 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + ELSE +* +* ==== Got NS/2 or fewer shifts? Use DLAQR4 or +* . DLAHQR on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL DLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, WORK, + $ LWORK, INF ) + ELSE + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, INF ) + END IF + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. ==== +* + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) +* . Bubble sort keeps complex conjugate +* . pairs together. ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + SORTED = .false. +* + SWAP = WR( I ) + WR( I ) = WR( I+1 ) + WR( I+1 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I+1 ) + WI( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF +* +* ==== Shuffle shifts into pairs of real shifts +* . and pairs of complex conjugate shifts +* . assuming complex conjugate shifts are +* . already adjacent to one another. (Yes, +* . they are.) ==== +* + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN +* + SWAP = WR( I ) + WR( I ) = WR( I-1 ) + WR( I-1 ) = WR( I-2 ) + WR( I-2 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I-1 ) + WI( I-1 ) = WI( I-2 ) + WI( I-2 ) = SWAP + END IF + 70 CONTINUE + END IF +* +* ==== If there are only two shifts and both are +* . real, then use only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 80 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 90 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR0 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlaqr1.f @@ -0,0 +1,97 @@ + SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SI1, SI2, SR1, SR2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), V( * ) +* .. +* +* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a +* scalar multiple of the first column of the product +* +* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) +* +* scaling to avoid overflows and most underflows. It +* is assumed that either +* +* 1) sr1 = sr2 and si1 = -si2 +* or +* 2) si1 = si2 = 0. +* +* 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) DOUBLE PRECISION 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 +* +* SR1 (input) DOUBLE PRECISION +* SI1 The shifts in (*). +* SR2 +* SI2 +* +* V (output) DOUBLE PRECISION 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION H21S, H31S, S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* + $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + END IF + ELSE + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + + $ ABS( 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 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - + $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + + $ H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + + $ H21S*H( 3, 2 ) + END IF + END IF + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlaqr2.f @@ -0,0 +1,551 @@ + SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* This subroutine is identical to DLAQR3 except that it avoids +* recursion by calling DLAHQR instead of DLAQR4. +* +* +* ****************************************************************** +* Aggressive early deflation: +* +* This subroutine accepts as input an upper Hessenberg matrix +* H and performs an orthogonal similarity transformation +* designed to detect and deflate fully converged eigenvalues from +* a trailing principal submatrix. On output H has been over- +* written by a new Hessenberg matrix that is a perturbation of +* an orthogonal similarity transformation of H. It is to be +* hoped that the final version of H has many zero subdiagonal +* entries. +* +* ****************************************************************** +* WANTT (input) LOGICAL +* If .TRUE., then the Hessenberg matrix H is fully updated +* so that the quasi-triangular Schur factor may be +* computed (in cooperation with the calling subroutine). +* If .FALSE., then only enough of H is updated to preserve +* the eigenvalues. +* +* WANTZ (input) LOGICAL +* If .TRUE., then the orthogonal matrix Z is updated so +* so that the orthogonal Schur factor may be computed +* (in cooperation with the calling subroutine). +* If .FALSE., then Z is not referenced. +* +* N (input) INTEGER +* The order of the matrix H and (if WANTZ is .TRUE.) the +* order of the orthogonal matrix Z. +* +* KTOP (input) INTEGER +* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +* KBOT and KTOP together determine an isolated block +* along the diagonal of the Hessenberg matrix. +* +* KBOT (input) INTEGER +* It is assumed without a check that either +* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +* determine an isolated block along the diagonal of the +* Hessenberg matrix. +* +* NW (input) INTEGER +* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +* +* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +* On input the initial N-by-N section of H stores the +* Hessenberg matrix undergoing aggressive early deflation. +* On output H has been transformed by an orthogonal +* similarity transformation, perturbed, and the returned +* to Hessenberg form that (it is to be hoped) has some +* zero subdiagonal entries. +* +* LDH (input) integer +* Leading dimension of H just as declared in the calling +* subroutine. N .LE. LDH +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) +* IF WANTZ is .TRUE., then on output, the orthogonal +* similarity transformation mentioned above has been +* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ is .FALSE., then Z is unreferenced. +* +* LDZ (input) integer +* The leading dimension of Z just as declared in the +* calling subroutine. 1 .LE. LDZ. +* +* NS (output) integer +* The number of unconverged (ie approximate) eigenvalues +* returned in SR and SI that may be used as shifts by the +* calling subroutine. +* +* ND (output) integer +* The number of converged eigenvalues uncovered by this +* subroutine. +* +* SR (output) DOUBLE PRECISION array, dimension KBOT +* SI (output) DOUBLE PRECISION array, dimension KBOT +* On output, the real and imaginary parts of approximate +* eigenvalues that may be used for shifts are stored in +* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +* The real and imaginary parts of converged eigenvalues +* are stored in SR(KBOT-ND+1) through SR(KBOT) and +* SI(KBOT-ND+1) through SI(KBOT), respectively. +* +* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) +* An NW-by-NW work array. +* +* LDV (input) integer scalar +* The leading dimension of V just as declared in the +* calling subroutine. NW .LE. LDV +* +* NH (input) integer scalar +* The number of columns of T. NH.GE.NW. +* +* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) +* +* LDT (input) integer +* The leading dimension of T just as declared in the +* calling subroutine. NW .LE. LDT +* +* NV (input) integer +* The number of rows of work array WV available for +* workspace. NV.GE.NW. +* +* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) +* +* LDWV (input) integer +* The leading dimension of W just as declared in the +* calling subroutine. NW .LE. LDV +* +* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. +* On exit, WORK(1) is set to an estimate of the optimal value +* of LWORK for the given values of N, NW, KTOP and KBOT. +* +* LWORK (input) integer +* The dimension of the work array WORK. LWORK = 2*NW +* suffices, but greater efficiency may result from larger +* values of LWORK. +* +* If LWORK = -1, then a workspace query is assumed; DLAQR2 +* only estimates the optimal workspace size for the given +* values of N, NW, KTOP and KBOT. The estimate is returned +* in WORK(1). No error message related to LWORK is issued +* by XERBLA. Neither H nor Z are accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, + $ LWKOPT + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLARF, DLARFG, DLASET, DORGHR, DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORGHR ==== +* + CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT.BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of DORGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR2 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlaqr3.f @@ -0,0 +1,561 @@ + SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ****************************************************************** +* Aggressive early deflation: +* +* This subroutine accepts as input an upper Hessenberg matrix +* H and performs an orthogonal similarity transformation +* designed to detect and deflate fully converged eigenvalues from +* a trailing principal submatrix. On output H has been over- +* written by a new Hessenberg matrix that is a perturbation of +* an orthogonal similarity transformation of H. It is to be +* hoped that the final version of H has many zero subdiagonal +* entries. +* +* ****************************************************************** +* WANTT (input) LOGICAL +* If .TRUE., then the Hessenberg matrix H is fully updated +* so that the quasi-triangular Schur factor may be +* computed (in cooperation with the calling subroutine). +* If .FALSE., then only enough of H is updated to preserve +* the eigenvalues. +* +* WANTZ (input) LOGICAL +* If .TRUE., then the orthogonal matrix Z is updated so +* so that the orthogonal Schur factor may be computed +* (in cooperation with the calling subroutine). +* If .FALSE., then Z is not referenced. +* +* N (input) INTEGER +* The order of the matrix H and (if WANTZ is .TRUE.) the +* order of the orthogonal matrix Z. +* +* KTOP (input) INTEGER +* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +* KBOT and KTOP together determine an isolated block +* along the diagonal of the Hessenberg matrix. +* +* KBOT (input) INTEGER +* It is assumed without a check that either +* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +* determine an isolated block along the diagonal of the +* Hessenberg matrix. +* +* NW (input) INTEGER +* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +* +* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +* On input the initial N-by-N section of H stores the +* Hessenberg matrix undergoing aggressive early deflation. +* On output H has been transformed by an orthogonal +* similarity transformation, perturbed, and the returned +* to Hessenberg form that (it is to be hoped) has some +* zero subdiagonal entries. +* +* LDH (input) integer +* Leading dimension of H just as declared in the calling +* subroutine. N .LE. LDH +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) +* IF WANTZ is .TRUE., then on output, the orthogonal +* similarity transformation mentioned above has been +* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ is .FALSE., then Z is unreferenced. +* +* LDZ (input) integer +* The leading dimension of Z just as declared in the +* calling subroutine. 1 .LE. LDZ. +* +* NS (output) integer +* The number of unconverged (ie approximate) eigenvalues +* returned in SR and SI that may be used as shifts by the +* calling subroutine. +* +* ND (output) integer +* The number of converged eigenvalues uncovered by this +* subroutine. +* +* SR (output) DOUBLE PRECISION array, dimension KBOT +* SI (output) DOUBLE PRECISION array, dimension KBOT +* On output, the real and imaginary parts of approximate +* eigenvalues that may be used for shifts are stored in +* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +* The real and imaginary parts of converged eigenvalues +* are stored in SR(KBOT-ND+1) through SR(KBOT) and +* SI(KBOT-ND+1) through SI(KBOT), respectively. +* +* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) +* An NW-by-NW work array. +* +* LDV (input) integer scalar +* The leading dimension of V just as declared in the +* calling subroutine. NW .LE. LDV +* +* NH (input) integer scalar +* The number of columns of T. NH.GE.NW. +* +* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) +* +* LDT (input) integer +* The leading dimension of T just as declared in the +* calling subroutine. NW .LE. LDT +* +* NV (input) integer +* The number of rows of work array WV available for +* workspace. NV.GE.NW. +* +* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) +* +* LDWV (input) integer +* The leading dimension of W just as declared in the +* calling subroutine. NW .LE. LDV +* +* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. +* On exit, WORK(1) is set to an estimate of the optimal value +* of LWORK for the given values of N, NW, KTOP and KBOT. +* +* LWORK (input) integer +* The dimension of the work array WORK. LWORK = 2*NW +* suffices, but greater efficiency may result from larger +* values of LWORK. +* +* If LWORK = -1, then a workspace query is assumed; DLAQR3 +* only estimates the optimal workspace size for the given +* values of N, NW, KTOP and KBOT. The estimate is returned +* in WORK(1). No error message related to LWORK is issued +* by XERBLA. Neither H nor Z are accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================== +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORGHR, + $ DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORGHR ==== +* + CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DLAQR4 ==== +* + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, + $ V, LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) + END IF +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT.BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of DORGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR3 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlaqr4.f @@ -0,0 +1,640 @@ + SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* This subroutine implements one level of recursion for DLAQR0. +* It is a complete implementation of the small bulge multi-shift +* QR algorithm. It may be called by DLAQR0 and, for large enough +* deflation window size, it may be called by DLAQR3. This +* subroutine is identical to DLAQR0 except that it calls DLAQR2 +* instead of DLAQR3. +* +* Purpose +* ======= +* +* DLAQR4 computes the eigenvalues of a Hessenberg matrix H +* and, optionally, the matrices T and Z from the Schur decomposition +* H = Z T Z**T, where T is an upper quasi-triangular matrix (the +* Schur form), and Z is the orthogonal matrix of Schur vectors. +* +* Optionally Z may be postmultiplied into an input orthogonal +* 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 orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +* +* Arguments +* ========= +* +* WANTT (input) LOGICAL +* = .TRUE. : the full Schur form T is required; +* = .FALSE.: only eigenvalues are required. +* +* WANTZ (input) LOGICAL +* = .TRUE. : the matrix of Schur vectors Z is required; +* = .FALSE.: Schur vectors are not required. +* +* 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 and, if ILO.GT.1, +* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +* previous call to DGEBAL, and then passed to DGEHRD when the +* matrix output by DGEBAL 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) DOUBLE PRECISION array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and WANTT is .TRUE., then H contains +* the upper quasi-triangular matrix T from the Schur +* decomposition (the Schur form); 2-by-2 diagonal blocks +* (corresponding to complex conjugate pairs of eigenvalues) +* are returned in standard form, with H(i,i) = H(i+1,i+1) +* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is +* .FALSE., then 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.) +* +* This subroutine may explicitly set 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). +* +* WR (output) DOUBLE PRECISION array, dimension (IHI) +* WI (output) DOUBLE PRECISION array, dimension (IHI) +* The real and imaginary parts, respectively, of the computed +* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) +* and WI(ILO:IHI). If two eigenvalues are computed as a +* complex conjugate pair, they are stored in consecutive +* elements of WR and WI, say the i-th and (i+1)th, with +* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then +* the eigenvalues are stored in the same order as on the +* diagonal of the Schur form returned in H, with +* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +* WI(i+1) = -WI(i). +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. +* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) +* If WANTZ is .FALSE., then Z is not referenced. +* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +* (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 WANTZ is .TRUE. +* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK +* On exit, if LWORK = -1, 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 DLAQR4 does a workspace query. +* In this case, DLAQR4 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 +* .GT. 0: if INFO = i, DLAQR4 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 WANT is .FALSE., 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 WANTT is .TRUE., then on exit +* +* (*) (initial value of H)*U = U*(final value of H) +* +* where U is an orthogonal matrix. The final +* value of H is upper Hessenberg and quasi-triangular +* in rows and columns INFO+1 through IHI. +* +* If INFO .GT. 0 and WANTZ is .TRUE., then on exit +* +* (final value of Z(ILO:IHI,ILOZ:IHIZ) +* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +* +* where U is the orthogonal matrix in (*) (regard- +* less of the value of WANTT.) +* +* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +* accessed. +* +* ================================================================ +* 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 +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by increasing the size of the +* . deflation window after KEXNW iterations. ===== +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use DLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to DLAQR2 ==== +* + CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 80 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 90 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if DLAQR2 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . DLAQR2 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + ELSE +* +* ==== Got NS/2 or fewer shifts? Use DLAHQR +* . on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), + $ 1, 1, ZDUM, 1, INF ) + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. ==== +* + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) +* . Bubble sort keeps complex conjugate +* . pairs together. ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + SORTED = .false. +* + SWAP = WR( I ) + WR( I ) = WR( I+1 ) + WR( I+1 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I+1 ) + WI( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF +* +* ==== Shuffle shifts into pairs of real shifts +* . and pairs of complex conjugate shifts +* . assuming complex conjugate shifts are +* . already adjacent to one another. (Yes, +* . they are.) ==== +* + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN +* + SWAP = WR( I ) + WR( I ) = WR( I-1 ) + WR( I-1 ) = WR( I-2 ) + WR( I-2 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I-1 ) + WI( I-1 ) = WI( I-2 ) + WI( I-2 ) = SWAP + END IF + 70 CONTINUE + END IF +* +* ==== If there are only two shifts and both are +* . real, then use only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 80 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 90 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR4 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlaqr5.f @@ -0,0 +1,812 @@ + SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, + $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, + $ LDU, NV, WV, LDWV, NH, WH, LDWH ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), + $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* This auxiliary subroutine called by DLAQR0 performs a +* single small-bulge multi-shift QR sweep. +* +* WANTT (input) logical scalar +* WANTT = .true. if the quasi-triangular Schur factor +* is being computed. WANTT is set to .false. otherwise. +* +* WANTZ (input) logical scalar +* WANTZ = .true. if the orthogonal Schur factor is being +* computed. WANTZ is set to .false. otherwise. +* +* KACC22 (input) integer with value 0, 1, or 2. +* Specifies the computation mode of far-from-diagonal +* orthogonal updates. +* = 0: DLAQR5 does not accumulate reflections and does not +* use matrix-matrix multiply to update far-from-diagonal +* matrix entries. +* = 1: DLAQR5 accumulates reflections and uses matrix-matrix +* multiply to update the far-from-diagonal matrix entries. +* = 2: DLAQR5 accumulates reflections, uses matrix-matrix +* multiply to update the far-from-diagonal matrix entries, +* and takes advantage of 2-by-2 block structure during +* matrix multiplies. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H upon which this +* subroutine operates. +* +* KTOP (input) integer scalar +* KBOT (input) integer scalar +* These are the first and last rows and columns of an +* isolated diagonal block upon which the QR sweep is to be +* applied. It is assumed without a check that +* either KTOP = 1 or H(KTOP,KTOP-1) = 0 +* and +* either KBOT = N or H(KBOT+1,KBOT) = 0. +* +* NSHFTS (input) integer scalar +* NSHFTS gives the number of simultaneous shifts. NSHFTS +* must be positive and even. +* +* SR (input) DOUBLE PRECISION array of size (NSHFTS) +* SI (input) DOUBLE PRECISION array of size (NSHFTS) +* SR contains the real parts and SI contains the imaginary +* parts of the NSHFTS shifts of origin that define the +* multi-shift QR sweep. +* +* H (input/output) DOUBLE PRECISION array of size (LDH,N) +* On input H contains a Hessenberg matrix. On output a +* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied +* to the isolated diagonal block in rows and columns KTOP +* through KBOT. +* +* LDH (input) integer scalar +* LDH is the leading dimension of H just as declared in the +* calling procedure. LDH.GE.MAX(1,N). +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N +* +* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI) +* If WANTZ = .TRUE., then the QR Sweep orthogonal +* similarity transformation is accumulated into +* Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ = .FALSE., then Z is unreferenced. +* +* LDZ (input) integer scalar +* LDA is the leading dimension of Z just as declared in +* the calling procedure. LDZ.GE.N. +* +* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2) +* +* LDV (input) integer scalar +* LDV is the leading dimension of V as declared in the +* calling procedure. LDV.GE.3. +* +* U (workspace) DOUBLE PRECISION array of size +* (LDU,3*NSHFTS-3) +* +* LDU (input) integer scalar +* LDU is the leading dimension of U just as declared in the +* in the calling subroutine. LDU.GE.3*NSHFTS-3. +* +* NH (input) integer scalar +* NH is the number of columns in array WH available for +* workspace. NH.GE.1. +* +* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH) +* +* LDWH (input) integer scalar +* Leading dimension of WH just as declared in the +* calling procedure. LDWH.GE.3*NSHFTS-3. +* +* NV (input) integer scalar +* NV is the number of rows in WV agailable for workspace. +* NV.GE.1. +* +* WV (workspace) DOUBLE PRECISION array of size +* (LDWV,3*NSHFTS-3) +* +* LDWV (input) integer scalar +* LDWV is the leading dimension of WV as declared in the +* in the calling subroutine. LDWV.GE.NV. +* +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ============================================================ +* Reference: +* +* 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. +* +* ============================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM, + $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, + $ ULP + INTEGER I, 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 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. +* + INTRINSIC ABS, DBLE, MAX, MIN, MOD +* .. +* .. Local Arrays .. + DOUBLE PRECISION VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, + $ DTRMM +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( NSHFTS.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( KTOP.GE.KBOT ) + $ RETURN +* +* ==== Shuffle shifts into pairs of real shifts and pairs +* . of complex conjugate shifts assuming complex +* . conjugate shifts are already adjacent to one +* . another. ==== +* + DO 10 I = 1, NSHFTS - 2, 2 + IF( SI( I ).NE.-SI( I+1 ) ) THEN +* + SWAP = SR( I ) + SR( I ) = SR( I+1 ) + SR( I+1 ) = SR( I+2 ) + SR( I+2 ) = SWAP +* + SWAP = SI( I ) + SI( I ) = SI( I+1 ) + SI( I+1 ) = SI( I+2 ) + SI( I+2 ) = SWAP + END IF + 10 CONTINUE +* +* ==== NSHFTS is supposed to be even, but if is odd, +* . then simply reduce it by one. The shuffle above +* . ensures that the dropped shift is real and that +* . the remaining shifts are paired. ==== +* + NS = NSHFTS - MOD( NSHFTS, 2 ) +* +* ==== Machine constants for deflation ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + NBMPS = NS / 2 +* +* ==== KDU = width of slab ==== +* + KDU = 6*NBMPS - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) +* +* ==== Near-the-diagonal bulge chase. The following loop +* . performs the near-the-diagonal part of a small bulge +* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal +* . chunk extends from column INCOL to column NDCOL +* . (including both column INCOL and column NDCOL). The +* . following loop chases a 3*NBMPS column long chain of +* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL +* . may be less than KTOP and and NDCOL may be greater than +* . KBOT indicating phantom columns from which to chase +* . bulges before they are actually introduced or to which +* . to chase bulges beyond column KBOT.) ==== +* + DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) +* +* ==== Bulges number MTOP to MBOT are active double implicit +* . shift bulges. There may or may not also be small +* . 2-by-2 bulge, if there is room. The inactive bulges +* . (if any) must wait until the active bulges have moved +* . down the diagonal to make room. The phantom matrix +* . paradigm described above helps keep track. ==== +* + 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 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + DO 20 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ V( 1, M ) ) + ALPHA = V( 1, M ) + CALL DLARFG( 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 DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. (The +* . initial bulge is always collapsed.) Use +* . the two-small-subdiagonals trick to try +* . to get it started again. If V(2,M).NE.0 and +* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then +* . this bulge is collapsing into a zero +* . subdiagonal. It will be restarted next +* . trip through the loop.) +* + IF( V( 1, M ).NE.ZERO .AND. + $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, + $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) + $ THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K). If the +* . fill resulting from the new reflector +* . is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ VT ) + SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) + + $ ABS( VT( 3 ) ) + IF( SCL.NE.ZERO ) THEN + VT( 1 ) = VT( 1 ) / SCL + VT( 2 ) = VT( 2 ) / SCL + VT( 3 ) = VT( 3 ) / SCL + END IF +* +* ==== The following is the traditional and +* . conservative two-small-subdiagonals +* . test. ==== +* . + IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+ + $ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )* + $ ( ABS( H( K, K ) )+ABS( H( K+1, + $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. If +* . the old reflector is diagonal (only +* . possible with underflows), then +* . change it to I. Otherwise, use +* . it with trepidation. ==== +* + IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) + $ THEN + V( 1, M ) = ZERO + ELSE + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + END IF + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + ALPHA = VT( 1 ) + CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) + + $ H( K+3, K )*VT( 3 ) + H( K+1, K ) = H( K+1, K ) - VT( 1 )*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 + 20 CONTINUE +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), + $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), + $ V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + ELSE +* +* ==== Initialize V(1,M22) here to avoid possible undefined +* . variable problems later. ==== +* + V( 1, M22 ) = ZERO + END IF +* +* ==== Multiply H by reflections from the left ==== +* + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 40 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 30 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* + $ H( K+2, J )+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 ) + 30 CONTINUE + 40 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 50 J = MAX( K+1, KTOP ), JBOT + REFSUM = V( 1, M22 )*( H( K+1, J )+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 ) + 50 CONTINUE + END IF +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 90 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 60 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*V( 2, M ) + H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) + 60 CONTINUE +* + IF( ACCUM ) THEN +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + KMS = K - INCOL + DO 70 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*V( 2, M ) + U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) + 70 CONTINUE + ELSE IF( WANTZ ) THEN +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + DO 80 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*V( 2, M ) + Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) + 80 CONTINUE + END IF + END IF + 90 CONTINUE +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN + DO 100 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*V( 2, M22 ) + 100 CONTINUE +* + IF( ACCUM ) THEN + KMS = K - INCOL + DO 110 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*V( 2, M22 ) + 110 CONTINUE + ELSE IF( WANTZ ) THEN + DO 120 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*V( 2, M22 ) + 120 CONTINUE + END IF + END IF +* +* ==== Vigilant deflation check ==== +* + 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 130 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) +* +* ==== The following convergence test requires that +* . the tradition small-compared-to-nearby-diagonals +* . criterion and the Ahues & Tisseur (LAWN 122, 1997) +* . criteria both be satisfied. The latter improves +* . accuracy in some examples. Falling back on an +* . alternate convergence criterion when TST1 or TST2 +* . is zero (as done here) is traditional but probably +* . unnecessary. ==== +* + IF( H( K+1, K ).NE.ZERO ) THEN + TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) + IF( TST1.EQ.ZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + ABS( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + ABS( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + ABS( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) + END IF + IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H11 = MAX( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) +* + IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 130 CONTINUE +* +* ==== Fill in the last row of each bulge. ==== +* + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 140 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*V( 2, M ) + H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) + 140 CONTINUE +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 150 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + 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 +* +* ==== Updates not exploiting the 2-by-2 block +* . structure of U. K1 and NU keep track of +* . the location and size of U in the special +* . cases of introducing bulges and chasing +* . bulges off the bottom. In these special +* . cases and in case the number of shifts +* . is NS = 2, there is no 2-by-2 block +* . structure to exploit. ==== +* + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 +* +* ==== Horizontal Multiply ==== +* + DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 160 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 170 CONTINUE +* +* ==== Z multiply (also vertical) ==== +* + IF( WANTZ ) THEN + DO 180 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 180 CONTINUE + END IF + ELSE +* +* ==== Updates exploiting U's 2-by-2 block structure. +* . (I2, I4, J2, J4 are the last rows and columns +* . of the blocks.) ==== +* + I2 = ( KDU+1 ) / 2 + I4 = KDU + J2 = I4 - I2 + J4 = KDU +* +* ==== KZS and KNZ deal with the band of zeros +* . along the diagonal of one of the triangular +* . blocks. ==== +* + KZS = ( J4-J2 ) - ( NS+1 ) + KNZ = NS + 1 +* +* ==== Horizontal multiply ==== +* + DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) +* +* ==== Multiply top of H by U11' ==== +* + CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H bottom of WH ==== +* + CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( '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 ) +* +* ==== Copy it back ==== +* + CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 190 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( '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 ) +* +* ==== Copy it back ==== +* + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 200 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( WANTZ ) THEN + DO 210 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL DLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U12 ==== +* + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( '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 ) +* +* ==== Copy the result back to Z ==== +* + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 210 CONTINUE + END IF + END IF + END IF + 220 CONTINUE +* +* ==== End of DLAQR5 ==== +* + END
--- a/libcruft/lapack/dlarf.f +++ b/libcruft/lapack/dlarf.f @@ -1,9 +1,8 @@ SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE
--- a/libcruft/lapack/dlarfb.f +++ b/libcruft/lapack/dlarfb.f @@ -1,10 +1,9 @@ SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS
--- a/libcruft/lapack/dlarfg.f +++ b/libcruft/lapack/dlarfg.f @@ -1,9 +1,8 @@ SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
--- a/libcruft/lapack/dlarft.f +++ b/libcruft/lapack/dlarft.f @@ -1,9 +1,8 @@ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV
--- a/libcruft/lapack/dlarfx.f +++ b/libcruft/lapack/dlarfx.f @@ -1,9 +1,8 @@ SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE
--- a/libcruft/lapack/dlartg.f +++ b/libcruft/lapack/dlartg.f @@ -1,9 +1,8 @@ SUBROUTINE DLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN @@ -45,6 +44,9 @@ * R (output) DOUBLE PRECISION * The nonzero component of the rotated vector. * +* This version has a few statements commented out for thread safety +* (machine parameters are computed on each entry). 10 feb 03, SJH. +* * ===================================================================== * * .. Parameters .. @@ -56,7 +58,7 @@ PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. - LOGICAL FIRST +* LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. @@ -68,21 +70,21 @@ INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. - SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. - DATA FIRST / .TRUE. / +* DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * - IF( FIRST ) THEN - FIRST = .FALSE. +* IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 - END IF +* FIRST = .FALSE. +* END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO
--- a/libcruft/lapack/dlas2.f +++ b/libcruft/lapack/dlas2.f @@ -1,9 +1,8 @@ SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION F, G, H, SSMAX, SSMIN
--- a/libcruft/lapack/dlascl.f +++ b/libcruft/lapack/dlascl.f @@ -1,9 +1,8 @@ SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TYPE @@ -62,7 +61,7 @@ * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * -* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. *
--- a/libcruft/lapack/dlaset.f +++ b/libcruft/lapack/dlaset.f @@ -1,9 +1,8 @@ SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dlasq1.f +++ b/libcruft/lapack/dlasq1.f @@ -1,9 +1,8 @@ SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, N @@ -67,7 +66,7 @@ DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX * .. * .. External Subroutines .. - EXTERNAL DLAS2, DLASQ2, DLASRT, XERBLA + EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH
--- a/libcruft/lapack/dlasq2.f +++ b/libcruft/lapack/dlasq2.f @@ -1,9 +1,10 @@ SUBROUTINE DLASQ2( N, Z, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH. * * .. Scalar Arguments .. INTEGER INFO, N @@ -29,7 +30,7 @@ * Note : DLASQ2 defines a logical variable, IEEE, which is true * on machines which follow ieee-754 floating-point standard in their * handling of infinities and NaNs, and false otherwise. This variable -* is passed to DLASQ3. +* is passed to DLAZQ3. * * Arguments * ========= @@ -76,13 +77,13 @@ * .. Local Scalars .. LOGICAL IEEE INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, - $ N0, NBIG, NDIV, NFAIL, PP, SPLT - DOUBLE PRECISION D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN, - $ QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL, - $ TOL2, TRACE, ZMAX + $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE + DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E, + $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN, + $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX * .. * .. External Subroutines .. - EXTERNAL DLASQ3, DLASRT, XERBLA + EXTERNAL DLAZQ3, DLASRT, XERBLA * .. * .. External Functions .. INTEGER ILAENV @@ -90,7 +91,7 @@ EXTERNAL DLAMCH, ILAENV * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT + INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * @@ -286,6 +287,16 @@ PP = 1 - PP 80 CONTINUE * +* Initialise variables to pass to DLAZQ3 +* + TTYPE = 0 + DMIN1 = ZERO + DMIN2 = ZERO + DN = ZERO + DN1 = ZERO + DN2 = ZERO + TAU = ZERO +* ITER = 2 NFAIL = 0 NDIV = 2*( N0-I0 ) @@ -336,7 +347,7 @@ 100 CONTINUE I0 = I4 / 4 * -* Store EMIN for passing to DLASQ3. +* Store EMIN for passing to DLAZQ3. * Z( 4*N0-1 ) = EMIN * @@ -355,8 +366,9 @@ * * While submatrix unfinished take a good dqds step. * - CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE ) + CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU ) * PP = 1 - PP *
--- a/libcruft/lapack/dlasq3.f +++ b/libcruft/lapack/dlasq3.f @@ -1,10 +1,9 @@ SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* May 17, 2000 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL IEEE @@ -86,7 +85,7 @@ EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SQRT + INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Save statement .. SAVE TTYPE @@ -197,8 +196,6 @@ END IF END IF * - 70 CONTINUE -* IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN *
--- a/libcruft/lapack/dlasq4.f +++ b/libcruft/lapack/dlasq4.f @@ -1,10 +1,9 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE @@ -32,7 +31,7 @@ * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * -* NOIN (input) INTEGER +* N0IN (input) INTEGER * The value of N0 at start of EIGTEST. * * DMIN (input) DOUBLE PRECISION
--- a/libcruft/lapack/dlasq5.f +++ b/libcruft/lapack/dlasq5.f @@ -1,10 +1,9 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2, IEEE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* May 17, 2000 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL IEEE
--- a/libcruft/lapack/dlasq6.f +++ b/libcruft/lapack/dlasq6.f @@ -1,10 +1,9 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER I0, N0, PP
--- a/libcruft/lapack/dlasr.f +++ b/libcruft/lapack/dlasr.f @@ -1,9 +1,8 @@ SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE @@ -16,44 +15,77 @@ * Purpose * ======= * -* DLASR performs the transformation -* -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) -* -* where A is an m by n real matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): -* -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* This version vectorises across rows of the array A when SIDE = 'L'. +* DLASR applies a sequence of plane rotations to a real matrix A, +* from either the left or the right. +* +* When SIDE = 'L', the transformation takes the form +* +* A := P*A +* +* and when SIDE = 'R', the transformation takes the form +* +* A := A*P**T +* +* where P is an orthogonal matrix consisting of a sequence of z plane +* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', +* and P**T is the transpose of P. +* +* When DIRECT = 'F' (Forward sequence), then +* +* P = P(z-1) * ... * P(2) * P(1) +* +* and when DIRECT = 'B' (Backward sequence), then +* +* P = P(1) * P(2) * ... * P(z-1) +* +* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation +* +* R(k) = ( c(k) s(k) ) +* = ( -s(k) c(k) ). +* +* When PIVOT = 'V' (Variable pivot), the rotation is performed +* for the plane (k,k+1), i.e., P(k) has the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears as a rank-2 modification to the identity matrix in +* rows and columns k and k+1. +* +* When PIVOT = 'T' (Top pivot), the rotation is performed for the +* plane (1,k+1), so P(k) has the form +* +* P(k) = ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears in rows and columns 1 and k+1. +* +* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is +* performed for the plane (k,z), giving P(k) the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* +* where R(k) appears in rows and columns k and z. The rotations are +* performed without ever forming P(k) explicitly. * * Arguments * ========= @@ -62,13 +94,7 @@ * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A -* = 'R': Right, compute A:= A*P' -* -* DIRECT (input) CHARACTER*1 -* Specifies whether P is a forward or backward sequence of -* plane rotations. -* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) -* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) +* = 'R': Right, compute A:= A*P**T * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation @@ -77,6 +103,12 @@ * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * +* DIRECT (input) CHARACTER*1 +* Specifies whether P is a forward or backward sequence of +* plane rotations. +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) +* * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. @@ -85,18 +117,22 @@ * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * -* C, S (input) DOUBLE PRECISION arrays, dimension +* C (input) DOUBLE PRECISION array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The cosines c(k) of the plane rotations. +* +* S (input) DOUBLE PRECISION array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* The sines s(k) of the plane rotations. The 2-by-2 plane +* rotation part of the matrix P(k), R(k), has the form +* R(k) = ( c(k) s(k) ) +* ( -s(k) c(k) ). * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. +* The M-by-N matrix A. On exit, A is overwritten by P*A if +* SIDE = 'R' or by A*P**T if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M).
--- a/libcruft/lapack/dlasrt.f +++ b/libcruft/lapack/dlasrt.f @@ -1,9 +1,8 @@ SUBROUTINE DLASRT( ID, N, D, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER ID
--- a/libcruft/lapack/dlassq.f +++ b/libcruft/lapack/dlassq.f @@ -1,9 +1,8 @@ SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
--- a/libcruft/lapack/dlasv2.f +++ b/libcruft/lapack/dlasv2.f @@ -1,9 +1,8 @@ SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
--- a/libcruft/lapack/dlaswp.f +++ b/libcruft/lapack/dlaswp.f @@ -1,9 +1,8 @@ SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -41,7 +40,7 @@ * The last element of IPIV for which a row interchange will * be done. * -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) +* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged.
--- a/libcruft/lapack/dlasy2.f +++ b/libcruft/lapack/dlasy2.f @@ -1,10 +1,9 @@ SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR
--- a/libcruft/lapack/dlatbs.f +++ b/libcruft/lapack/dlatbs.f @@ -1,10 +1,9 @@ SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO
--- a/libcruft/lapack/dlatrd.f +++ b/libcruft/lapack/dlatrd.f @@ -1,9 +1,8 @@ SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO @@ -31,7 +30,7 @@ * Arguments * ========= * -* UPLO (input) CHARACTER +* UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored: * = 'U': Upper triangular
--- a/libcruft/lapack/dlatrs.f +++ b/libcruft/lapack/dlatrs.f @@ -1,10 +1,9 @@ SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO
--- a/libcruft/lapack/dlauu2.f +++ b/libcruft/lapack/dlauu2.f @@ -1,9 +1,8 @@ SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dlauum.f +++ b/libcruft/lapack/dlauum.f @@ -1,9 +1,8 @@ SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlazq3.f @@ -0,0 +1,302 @@ + SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE + DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX, + $ SIGMA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* Purpose +* ======= +* +* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. +* In case of failure it changes shifts, and tries again until output +* is positive. +* +* Arguments +* ========= +* +* I0 (input) INTEGER +* First index. +* +* N0 (input) INTEGER +* Last index. +* +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. +* +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. +* +* DMIN (output) DOUBLE PRECISION +* Minimum value of d. +* +* SIGMA (output) DOUBLE PRECISION +* Sum of shifts used in current segment. +* +* DESIG (input/output) DOUBLE PRECISION +* Lower order part of SIGMA +* +* QMAX (input) DOUBLE PRECISION +* Maximum value of q. +* +* NFAIL (output) INTEGER +* Number of times shift was too big. +* +* ITER (output) INTEGER +* Number of iterations. +* +* NDIV (output) INTEGER +* Number of divisions. +* +* IEEE (input) LOGICAL +* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). +* +* TTYPE (input/output) INTEGER +* Shift type. TTYPE is passed as an argument in order to save +* its value between calls to DLAZQ3 +* +* DMIN1 (input/output) REAL +* DMIN2 (input/output) REAL +* DN (input/output) REAL +* DN1 (input/output) REAL +* DN2 (input/output) REAL +* TAU (input/output) REAL +* These are passed as arguments in order to save their values +* between calls to DLAZQ3 +* +* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1, +* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of +* declaring them in a SAVE statment. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION CBIAS + PARAMETER ( CBIAS = 1.50D0 ) + DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD + PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, + $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) +* .. +* .. Local Scalars .. + INTEGER IPN4, J4, N0IN, NN + DOUBLE PRECISION EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2 +* .. +* .. External Subroutines .. + EXTERNAL DLASQ5, DLASQ6, DLAZQ4 +* .. +* .. External Function .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SQRT +* .. +* .. Executable Statements .. +* + N0IN = N0 + EPS = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + TOL = EPS*HUNDRD + TOL2 = TOL**2 + G = ZERO +* +* Check for deflation. +* + 10 CONTINUE +* + IF( N0.LT.I0 ) + $ RETURN + IF( N0.EQ.I0 ) + $ GO TO 20 + NN = 4*N0 + PP + IF( N0.EQ.( I0+1 ) ) + $ GO TO 40 +* +* Check whether E(N0-1) is negligible, 1 eigenvalue. +* + IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. + $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) + $ GO TO 30 +* + 20 CONTINUE +* + Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA + N0 = N0 - 1 + GO TO 10 +* +* Check whether E(N0-2) is negligible, 2 eigenvalues. +* + 30 CONTINUE +* + IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. + $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) + $ GO TO 50 +* + 40 CONTINUE +* + IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN + S = Z( NN-3 ) + Z( NN-3 ) = Z( NN-7 ) + Z( NN-7 ) = S + END IF + IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN + T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) + S = Z( NN-3 )*( Z( NN-5 ) / T ) + IF( S.LE.T ) THEN + S = Z( NN-3 )*( Z( NN-5 ) / + $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) + ELSE + S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) + END IF + T = Z( NN-7 ) + ( S+Z( NN-5 ) ) + Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) + Z( NN-7 ) = T + END IF + Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA + Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA + N0 = N0 - 2 + GO TO 10 +* + 50 CONTINUE +* +* Reverse the qd-array, if warranted. +* + IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN + IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN + IPN4 = 4*( I0+N0 ) + DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( J4-3 ) + Z( J4-3 ) = Z( IPN4-J4-3 ) + Z( IPN4-J4-3 ) = TEMP + TEMP = Z( J4-2 ) + Z( J4-2 ) = Z( IPN4-J4-2 ) + Z( IPN4-J4-2 ) = TEMP + TEMP = Z( J4-1 ) + Z( J4-1 ) = Z( IPN4-J4-5 ) + Z( IPN4-J4-5 ) = TEMP + TEMP = Z( J4 ) + Z( J4 ) = Z( IPN4-J4-4 ) + Z( IPN4-J4-4 ) = TEMP + 60 CONTINUE + IF( N0-I0.LE.4 ) THEN + Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) + Z( 4*N0-PP ) = Z( 4*I0-PP ) + END IF + DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) + Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), + $ Z( 4*I0+PP+3 ) ) + Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), + $ Z( 4*I0-PP+4 ) ) + QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) + DMIN = -ZERO + END IF + END IF +* + IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), + $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN +* +* Choose a shift. +* + CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE, G ) +* +* Call dqds until DMIN > 0. +* + 80 CONTINUE +* + CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, IEEE ) +* + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 +* +* Check status. +* + IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN +* +* Success. +* + GO TO 100 +* + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. + $ ABS( DN ).LT.TOL*SIGMA ) THEN +* +* Convergence hidden by negative DN. +* + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ZERO + GO TO 100 + ELSE IF( DMIN.LT.ZERO ) THEN +* +* TAU too big. Select new TAU and try again. +* + NFAIL = NFAIL + 1 + IF( TTYPE.LT.-22 ) THEN +* +* Failed twice. Play it safe. +* + TAU = ZERO + ELSE IF( DMIN1.GT.ZERO ) THEN +* +* Late failure. Gives excellent shift. +* + TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) + TTYPE = TTYPE - 11 + ELSE +* +* Early failure. Divide by 4. +* + TAU = QURTR*TAU + TTYPE = TTYPE - 12 + END IF + GO TO 80 + ELSE IF( DMIN.NE.DMIN ) THEN +* +* NaN. +* + TAU = ZERO + GO TO 80 + ELSE +* +* Possible underflow. Play it safe. +* + GO TO 90 + END IF + END IF +* +* Risk of underflow. +* + 90 CONTINUE + CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 + TAU = ZERO +* + 100 CONTINUE + IF( TAU.LT.SIGMA ) THEN + DESIG = DESIG + TAU + T = SIGMA + DESIG + DESIG = DESIG - ( T-SIGMA ) + ELSE + T = SIGMA + TAU + DESIG = SIGMA - ( T-TAU ) + DESIG + END IF + SIGMA = T +* + RETURN +* +* End of DLAZQ3 +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlazq4.f @@ -0,0 +1,330 @@ + SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, TAU, TTYPE, G ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER I0, N0, N0IN, PP, TTYPE + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* Purpose +* ======= +* +* DLAZQ4 computes an approximation TAU to the smallest eigenvalue +* using values of d from the previous transform. +* +* I0 (input) INTEGER +* First index. +* +* N0 (input) INTEGER +* Last index. +* +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. +* +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. +* +* N0IN (input) INTEGER +* The value of N0 at start of EIGTEST. +* +* DMIN (input) DOUBLE PRECISION +* Minimum value of d. +* +* DMIN1 (input) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ). +* +* DMIN2 (input) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ) and D( N0-1 ). +* +* DN (input) DOUBLE PRECISION +* d(N) +* +* DN1 (input) DOUBLE PRECISION +* d(N-1) +* +* DN2 (input) DOUBLE PRECISION +* d(N-2) +* +* TAU (output) DOUBLE PRECISION +* This is the shift. +* +* TTYPE (output) INTEGER +* Shift type. +* +* G (input/output) DOUBLE PRECISION +* G is passed as an argument in order to save its value between +* calls to DLAZQ4 +* +* Further Details +* =============== +* CNST1 = 9/16 +* +* This is a thread safe version of DLASQ4, which passes G through the +* argument list in place of declaring G in a SAVE statment. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION CNST1, CNST2, CNST3 + PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, + $ CNST3 = 1.050D0 ) + DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD + PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, + $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, HUNDRD = 100.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I4, NN, NP + DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* A negative DMIN forces the shift to take that absolute value +* TTYPE records the type of shift. +* + IF( DMIN.LE.ZERO ) THEN + TAU = -DMIN + TTYPE = -1 + RETURN + END IF +* + NN = 4*N0 + PP + IF( N0IN.EQ.N0 ) THEN +* +* No eigenvalues deflated. +* + IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN +* + B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) + B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) + A2 = Z( NN-7 ) + Z( NN-5 ) +* +* Cases 2 and 3. +* + IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN + GAP2 = DMIN2 - A2 - DMIN2*QURTR + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN + GAP1 = A2 - DN - ( B2 / GAP2 )*B2 + ELSE + GAP1 = A2 - DN - ( B1+B2 ) + END IF + IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN + S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) + TTYPE = -2 + ELSE + S = ZERO + IF( DN.GT.B1 ) + $ S = DN - B1 + IF( A2.GT.( B1+B2 ) ) + $ S = MIN( S, A2-( B1+B2 ) ) + S = MAX( S, THIRD*DMIN ) + TTYPE = -3 + END IF + ELSE +* +* Case 4. +* + TTYPE = -4 + S = QURTR*DMIN + IF( DMIN.EQ.DN ) THEN + GAM = DN + A2 = ZERO + IF( Z( NN-5 ) .GT. Z( NN-7 ) ) + $ RETURN + B2 = Z( NN-5 ) / Z( NN-7 ) + NP = NN - 9 + ELSE + NP = NN - 2*PP + B2 = Z( NP-2 ) + GAM = DN1 + IF( Z( NP-4 ) .GT. Z( NP-2 ) ) + $ RETURN + A2 = Z( NP-4 ) / Z( NP-2 ) + IF( Z( NN-9 ) .GT. Z( NN-11 ) ) + $ RETURN + B2 = Z( NN-9 ) / Z( NN-11 ) + NP = NN - 13 + END IF +* +* Approximate contribution to norm squared from I < NN-1. +* + A2 = A2 + B2 + DO 10 I4 = NP, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 20 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 20 + 10 CONTINUE + 20 CONTINUE + A2 = CNST3*A2 +* +* Rayleigh quotient residual bound. +* + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + END IF + ELSE IF( DMIN.EQ.DN2 ) THEN +* +* Case 5. +* + TTYPE = -5 + S = QURTR*DMIN +* +* Compute contribution to norm squared from I > NN-2. +* + NP = NN - 2*PP + B1 = Z( NP-2 ) + B2 = Z( NP-6 ) + GAM = DN2 + IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) + $ RETURN + A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) +* +* Approximate contribution to norm squared from I < NN-2. +* + IF( N0-I0.GT.2 ) THEN + B2 = Z( NN-13 ) / Z( NN-15 ) + A2 = A2 + B2 + DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 40 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 40 + 30 CONTINUE + 40 CONTINUE + A2 = CNST3*A2 + END IF +* + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + ELSE +* +* Case 6, no information to guide us. +* + IF( TTYPE.EQ.-6 ) THEN + G = G + THIRD*( ONE-G ) + ELSE IF( TTYPE.EQ.-18 ) THEN + G = QURTR*THIRD + ELSE + G = QURTR + END IF + S = G*DMIN + TTYPE = -6 + END IF +* + ELSE IF( N0IN.EQ.( N0+1 ) ) THEN +* +* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. +* + IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN +* +* Cases 7 and 8. +* + TTYPE = -7 + S = THIRD*DMIN1 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 60 + DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + A2 = B1 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) + $ GO TO 60 + 50 CONTINUE + 60 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN1 / ( ONE+B2**2 ) + GAP2 = HALF*DMIN2 - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + TTYPE = -8 + END IF + ELSE +* +* Case 9. +* + S = QURTR*DMIN1 + IF( DMIN1.EQ.DN1 ) + $ S = HALF*DMIN1 + TTYPE = -9 + END IF +* + ELSE IF( N0IN.EQ.( N0+2 ) ) THEN +* +* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. +* +* Cases 10 and 11. +* + IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN + TTYPE = -10 + S = THIRD*DMIN2 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 80 + DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*B1.LT.B2 ) + $ GO TO 80 + 70 CONTINUE + 80 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN2 / ( ONE+B2**2 ) + GAP2 = Z( NN-7 ) + Z( NN-9 ) - + $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + END IF + ELSE + S = QURTR*DMIN2 + TTYPE = -11 + END IF + ELSE IF( N0IN.GT.( N0+2 ) ) THEN +* +* Case 12, more than two eigenvalues deflated. No information. +* + S = ZERO + TTYPE = -12 + END IF +* + TAU = S + RETURN +* +* End of DLAZQ4 +* + END
--- a/libcruft/lapack/dorg2l.f +++ b/libcruft/lapack/dorg2l.f @@ -1,9 +1,8 @@ SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N
--- a/libcruft/lapack/dorg2r.f +++ b/libcruft/lapack/dorg2r.f @@ -1,9 +1,8 @@ SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N
--- a/libcruft/lapack/dorgbr.f +++ b/libcruft/lapack/dorgbr.f @@ -1,9 +1,8 @@ SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER VECT @@ -76,7 +75,7 @@ * reflector H(i) or G(i), which determines Q or P**T, as * returned by DGEBRD in its array argument TAUQ or TAUP. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dorghr.f +++ b/libcruft/lapack/dorghr.f @@ -1,9 +1,8 @@ SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N @@ -46,7 +45,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEHRD. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dorgl2.f +++ b/libcruft/lapack/dorgl2.f @@ -1,9 +1,8 @@ SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N
--- a/libcruft/lapack/dorglq.f +++ b/libcruft/lapack/dorglq.f @@ -1,9 +1,8 @@ SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N @@ -49,7 +48,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGELQF. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dorgql.f +++ b/libcruft/lapack/dorgql.f @@ -1,9 +1,8 @@ SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N @@ -50,7 +49,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQLF. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -93,9 +92,6 @@ * Test the input arguments * INFO = 0 - NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 @@ -105,9 +101,22 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQL', -INFO ) RETURN @@ -118,7 +127,6 @@ * Quick return if possible * IF( N.LE.0 ) THEN - WORK( 1 ) = 1 RETURN END IF *
--- a/libcruft/lapack/dorgqr.f +++ b/libcruft/lapack/dorgqr.f @@ -1,9 +1,8 @@ SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N @@ -50,7 +49,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dorgtr.f +++ b/libcruft/lapack/dorgtr.f @@ -1,9 +1,8 @@ SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO @@ -48,7 +47,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DSYTRD. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dorm2r.f +++ b/libcruft/lapack/dorm2r.f @@ -1,10 +1,9 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS
--- a/libcruft/lapack/dormbr.f +++ b/libcruft/lapack/dormbr.f @@ -1,10 +1,9 @@ SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT @@ -98,7 +97,7 @@ * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dorml2.f +++ b/libcruft/lapack/dorml2.f @@ -1,10 +1,9 @@ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS
--- a/libcruft/lapack/dormlq.f +++ b/libcruft/lapack/dormlq.f @@ -1,10 +1,9 @@ SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -76,7 +75,7 @@ * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dormqr.f +++ b/libcruft/lapack/dormqr.f @@ -1,10 +1,9 @@ SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -76,7 +75,7 @@ * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dormr3.f @@ -0,0 +1,206 @@ + SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORMR3 overwrites the general real m by n matrix C with +* +* Q * C if SIDE = 'L' and TRANS = 'N', or +* +* Q'* C if SIDE = 'L' and TRANS = 'T', or +* +* C * Q if SIDE = 'R' and TRANS = 'N', or +* +* C * Q' if SIDE = 'R' and TRANS = 'T', +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q' from the Left +* = 'R': apply Q or Q' from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply Q (No transpose) +* = 'T': apply Q' (Transpose) +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* L (input) INTEGER +* The number of columns of the matrix A containing +* the meaningful part of the Householder reflectors. +* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. +* +* A (input) DOUBLE PRECISION array, dimension +* (LDA,M) if SIDE = 'L', +* (LDA,N) if SIDE = 'R' +* The i-th row must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DTZRZF in the last k rows of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,K). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DTZRZF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m-by-n matrix C. +* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L', +* (M) if SIDE = 'R' +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* Based on contributions by +* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARZ, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMR3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JA = M - L + 1 + JC = 1 + ELSE + MI = M + JA = N - L + 1 + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)' is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) or H(i)' is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) or H(i)' +* + CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) +* + 10 CONTINUE +* + RETURN +* +* End of DORMR3 +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dormrz.f @@ -0,0 +1,293 @@ + SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* January 2007 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORMRZ overwrites the general real M-by-N matrix C with +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* where Q is a real orthogonal matrix defined as the product of k +* elementary reflectors +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N +* if SIDE = 'R'. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply Q or Q**T from the Left; +* = 'R': apply Q or Q**T from the Right. +* +* TRANS (input) CHARACTER*1 +* = 'N': No transpose, apply Q; +* = 'T': Transpose, apply Q**T. +* +* M (input) INTEGER +* The number of rows of the matrix C. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix C. N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines +* the matrix Q. +* If SIDE = 'L', M >= K >= 0; +* if SIDE = 'R', N >= K >= 0. +* +* L (input) INTEGER +* The number of columns of the matrix A containing +* the meaningful part of the Householder reflectors. +* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. +* +* A (input) DOUBLE PRECISION array, dimension +* (LDA,M) if SIDE = 'L', +* (LDA,N) if SIDE = 'R' +* The i-th row must contain the vector which defines the +* elementary reflector H(i), for i = 1,2,...,k, as returned by +* DTZRZF in the last k rows of its array argument A. +* A is modified by the routine but restored on exit. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,K). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DTZRZF. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the M-by-N matrix C. +* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. +* If SIDE = 'L', LWORK >= max(1,N); +* if SIDE = 'R', LWORK >= max(1,M). +* For optimum performance LWORK >= N*NB if SIDE = 'L', and +* LWORK >= M*NB if SIDE = 'R', where NB is the optimal +* blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* Based on contributions by +* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC, + $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARZB, DLARZT, DORMR3, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = MAX( 1, N ) + ELSE + NQ = N + NW = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 + ELSE +* +* Determine the block size. NB may be at most NBMAX, where +* NBMAX is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMRZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + JA = M - L + 1 + ELSE + MI = M + IC = 1 + JA = N - L + 1 + END IF +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA, + $ TAU( I ), T, LDT ) +* + IF( LEFT ) THEN +* +* H or H' is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H' is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H' +* + CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, + $ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ), + $ LDC, WORK, LDWORK ) + 10 CONTINUE +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DORMRZ +* + END
--- a/libcruft/lapack/dpbcon.f +++ b/libcruft/lapack/dpbcon.f @@ -1,10 +1,11 @@ SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO @@ -79,6 +80,9 @@ INTEGER IX, KASE DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX @@ -86,7 +90,7 @@ EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DLACON, DLATBS, DRSCL, XERBLA + EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS @@ -130,7 +134,7 @@ KASE = 0 NORMIN = 'N' 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN *
--- a/libcruft/lapack/dpbtf2.f +++ b/libcruft/lapack/dpbtf2.f @@ -1,9 +1,8 @@ SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dpbtrf.f +++ b/libcruft/lapack/dpbtrf.f @@ -1,9 +1,8 @@ SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dpbtrs.f +++ b/libcruft/lapack/dpbtrs.f @@ -1,9 +1,8 @@ SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dpocon.f +++ b/libcruft/lapack/dpocon.f @@ -1,10 +1,11 @@ SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO @@ -71,6 +72,9 @@ INTEGER IX, KASE DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX @@ -78,7 +82,7 @@ EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DLACON, DLATRS, DRSCL, XERBLA + EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX @@ -120,7 +124,7 @@ KASE = 0 NORMIN = 'N' 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN *
--- a/libcruft/lapack/dpotf2.f +++ b/libcruft/lapack/dpotf2.f @@ -1,9 +1,8 @@ SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dpotrf.f +++ b/libcruft/lapack/dpotrf.f @@ -1,9 +1,8 @@ SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dpotri.f +++ b/libcruft/lapack/dpotri.f @@ -1,9 +1,8 @@ SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dpotrs.f +++ b/libcruft/lapack/dpotrs.f @@ -1,9 +1,8 @@ SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dptsv.f +++ b/libcruft/lapack/dptsv.f @@ -1,9 +1,8 @@ SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 25, 1997 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS
--- a/libcruft/lapack/dpttrf.f +++ b/libcruft/lapack/dpttrf.f @@ -1,9 +1,8 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, N @@ -43,7 +42,7 @@ * > 0: if INFO = k, the leading minor of order k is not * positive definite; if k < N, the factorization could not * be completed, while if k = N, the factorization was -* completed, but D(N) = 0. +* completed, but D(N) <= 0. * * ===================================================================== *
--- a/libcruft/lapack/dpttrs.f +++ b/libcruft/lapack/dpttrs.f @@ -1,9 +1,8 @@ SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS
--- a/libcruft/lapack/dptts2.f +++ b/libcruft/lapack/dptts2.f @@ -1,9 +1,8 @@ SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER LDB, N, NRHS
--- a/libcruft/lapack/drscl.f +++ b/libcruft/lapack/drscl.f @@ -1,9 +1,8 @@ SUBROUTINE DRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
--- a/libcruft/lapack/dsteqr.f +++ b/libcruft/lapack/dsteqr.f @@ -1,9 +1,8 @@ SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER COMPZ
--- a/libcruft/lapack/dsterf.f +++ b/libcruft/lapack/dsterf.f @@ -1,9 +1,8 @@ SUBROUTINE DSTERF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, N
--- a/libcruft/lapack/dsyev.f +++ b/libcruft/lapack/dsyev.f @@ -1,9 +1,8 @@ SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -51,7 +50,7 @@ * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -80,7 +79,7 @@ * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LOPT, LWKOPT, NB + $ LLWORK, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. @@ -114,14 +113,15 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+2 )*N ) WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 END IF * IF( INFO.NE.0 ) THEN @@ -134,13 +134,12 @@ * Quick return if possible * IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) - WORK( 1 ) = 3 + WORK( 1 ) = 2 IF( WANTZ ) $ A( 1, 1 ) = ONE RETURN @@ -177,7 +176,6 @@ LLWORK = LWORK - INDWRK + 1 CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) - LOPT = 2*N + WORK( INDWRK ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * DORGTR to generate the orthogonal matrix, then call DSTEQR.
--- a/libcruft/lapack/dsytd2.f +++ b/libcruft/lapack/dsytd2.f @@ -1,9 +1,8 @@ SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/dsytrd.f +++ b/libcruft/lapack/dsytrd.f @@ -1,9 +1,8 @@ SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO @@ -65,7 +64,7 @@ * The scalar factors of the elementary reflectors (see Further * Details). * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/dtgevc.f +++ b/libcruft/lapack/dtgevc.f @@ -1,18 +1,17 @@ - SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -20,35 +19,31 @@ * Purpose * ======= * -* DTGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of real upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: +* DTGEVC computes some or all of the right and/or left eigenvectors of +* a pair of real matrices (S,P), where S is a quasi-triangular matrix +* and P is upper triangular. Matrix pairs of this type are produced by +* the generalized Schur factorization of a matrix pair (A,B): * -* (A - wB) * x = 0 and y**H * (A - wB) = 0 +* A = Q*S*Z**T, B = Q*P*Z**T * -* where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. +* as computed by DGGHRD + DHGEQZ. * -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input orthogonal -* matrices. If (A,B) was obtained from the generalized real-Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. -* -* A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal -* blocks. Corresponding to each 2-by-2 diagonal block is a complex -* conjugate pair of eigenvalues and eigenvectors; only one -* eigenvector of the pair is computed, namely the one corresponding -* to the eigenvalue with positive imaginary part. -* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* +* where y**H denotes the conjugate tranpose of y. +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal blocks of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the orthogonal factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). +* * Arguments * ========= * @@ -59,78 +54,84 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to the real -* eigenvalue w(j), SELECT(j) must be set to .TRUE. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must -* be set to .TRUE.. +* computed. If w(j) is a real eigenvalue, the corresponding +* real eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector +* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., +* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is +* set to .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER -* The order of the matrices A and B. N >= 0. +* The order of the matrices S and P. N >= 0. * -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The upper quasi-triangular matrix A. +* S (input) DOUBLE PRECISION array, dimension (LDS,N) +* The upper quasi-triangular matrix S from a generalized Schur +* factorization, as computed by DHGEQZ. * -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1, N). +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). * -* B (input) DOUBLE PRECISION array, dimension (LDB,N) -* The upper triangular matrix B. If A has a 2-by-2 diagonal -* block, then the corresponding 2-by-2 block of B must be -* diagonal with positive elements. +* P (input) DOUBLE PRECISION array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by DHGEQZ. +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks +* of S must be in positive diagonal form. * -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of left Schur vectors returned by DHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * +* Not referenced if SIDE = 'R'. +* * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must -* contain an N-by-N matrix Q (usually the orthogonal matrix Z +* contain an N-by-N matrix Z (usually the orthogonal matrix Z * of right Schur vectors returned by DHGEQZ). +* * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); -* if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by -* SELECT, stored consecutively in the columns of -* VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); +* if HOWMNY = 'B' or 'b', the matrix Z*X; +* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) +* specified by SELECT, stored consecutively in the +* columns of VR, in the same order as their +* eigenvalues. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. +* +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* The leading dimension of the array VR. LDVR >= 1, and if +* SIDE = 'R' or 'B', LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. @@ -199,7 +200,7 @@ * partial sums. Since FORTRAN arrays are stored columnwise, this has * the advantage that at each step, the elements of C that are accessed * are adjacent to one another, whereas with the rowwise method, the -* elements accessed at a step are spaced LDA (and LDB) words apart. +* elements accessed at a step are spaced LDS (and LDP) words apart. * * When finding left eigenvectors, the matrix in question is the * transpose of the one in storage, so the rowwise method then @@ -226,8 +227,8 @@ $ XSCALE * .. * .. Local Arrays .. - DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ), - $ SUMB( 2, 2 ) + DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), + $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME @@ -235,7 +236,7 @@ EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DGEMV, DLACPY, DLAG2, DLALN2, XERBLA + EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN @@ -252,7 +253,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -284,9 +285,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -305,7 +306,7 @@ GO TO 10 END IF IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) + IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN @@ -325,11 +326,11 @@ ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 - IF( A( J+1, J ).NE.ZERO ) THEN - IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR. - $ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. + IF( S( J+1, J ).NE.ZERO ) THEN + IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. + $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN - IF( A( J+2, J+1 ).NE.ZERO ) + IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF @@ -372,30 +373,30 @@ * blocks) of A and B to check for possible overflow in the * triangular solver. * - ANORM = ABS( A( 1, 1 ) ) + ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) - $ ANORM = ANORM + ABS( A( 2, 1 ) ) - BNORM = ABS( B( 1, 1 ) ) + $ ANORM = ANORM + ABS( S( 2, 1 ) ) + BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO - IF( A( J, J-1 ).EQ.ZERO ) THEN + IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) @@ -425,7 +426,7 @@ END IF NW = 1 IF( JE.LT.N ) THEN - IF( A( JE+1, JE ).NE.ZERO ) THEN + IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -444,8 +445,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -472,10 +473,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -517,7 +518,7 @@ * * Complex eigenvalue * - CALL DLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB, + CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI @@ -549,9 +550,9 @@ * * Compute first two components of eigenvector * - TEMP = ACOEF*A( JE+1, JE ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE+1, JE ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -560,10 +561,10 @@ ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO - TEMP = ACOEF*A( JE, JE+1 ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF* - $ A( JE+1, JE+1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP + TEMP = ACOEF*S( JE, JE+1 ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* + $ S( JE+1, JE+1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) @@ -586,11 +587,11 @@ END IF * NA = 1 - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 END IF END IF @@ -616,13 +617,13 @@ * Compute dot products * * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 -* a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) ) +* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close @@ -659,15 +660,15 @@ *$PL$ CMCHAR='*' * DO 110 JA = 1, NA - SUMA( JA, JW ) = ZERO - SUMB( JA, JW ) = ZERO + SUMS( JA, JW ) = ZERO + SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 - SUMA( JA, JW ) = SUMA( JA, JW ) + - $ A( JR, J+JA-1 )* + SUMS( JA, JW ) = SUMS( JA, JW ) + + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) - SUMB( JA, JW ) = SUMB( JA, JW ) + - $ B( JR, J+JA-1 )* + SUMP( JA, JW ) = SUMP( JA, JW ) + + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE @@ -687,15 +688,15 @@ * DO 130 JA = 1, NA IF( ILCPLX ) THEN - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) - - $ BCOEFI*SUMB( JA, 2 ) - SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) + - $ BCOEFR*SUMB( JA, 2 ) + - $ BCOEFI*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) - + $ BCOEFI*SUMP( JA, 2 ) + SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + + $ BCOEFR*SUMP( JA, 2 ) + + $ BCOEFI*SUMP( JA, 1 ) ELSE - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * @@ -703,7 +704,7 @@ * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * - CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA, + CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) @@ -790,7 +791,7 @@ END IF NW = 1 IF( JE.GT.1 ) THEN - IF( A( JE, JE-1 ).NE.ZERO ) THEN + IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -809,8 +810,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * @@ -839,10 +840,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -885,14 +886,14 @@ * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 - WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) - - $ ACOEF*A( JR, JE ) + WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - + $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * - CALL DLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB, + CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN @@ -924,9 +925,9 @@ * Compute first two components of eigenvector * and contribution to sums * - TEMP = ACOEF*A( JE, JE-1 ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE, JE-1 ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -935,10 +936,10 @@ ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO - TEMP = ACOEF*A( JE-1, JE ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF* - $ A( JE-1, JE-1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP + TEMP = ACOEF*S( JE-1, JE ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* + $ S( JE-1, JE-1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), @@ -958,12 +959,12 @@ CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 - WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) + - $ CREALB*B( JR, JE-1 ) - - $ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE ) - WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) + - $ CIMAGB*B( JR, JE-1 ) - - $ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE ) + WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + + $ CREALB*P( JR, JE-1 ) - + $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) + WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + + $ CIMAGB*P( JR, JE-1 ) - + $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * @@ -978,23 +979,23 @@ * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN - IF( A( J, J-1 ).NE.ZERO ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * - CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ), - $ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), + CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), + $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN @@ -1014,7 +1015,7 @@ 300 CONTINUE 310 CONTINUE * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * @@ -1052,19 +1053,19 @@ $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - - $ CIMAGA*A( JR, J+JA-1 ) + - $ CIMAGB*B( JR, J+JA-1 ) + $ CIMAGA*S( JR, J+JA-1 ) + + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE
--- a/libcruft/lapack/dtrcon.f +++ b/libcruft/lapack/dtrcon.f @@ -1,10 +1,11 @@ SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO @@ -84,6 +85,9 @@ INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX @@ -91,7 +95,7 @@ EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR * .. * .. External Subroutines .. - EXTERNAL DLACON, DLATRS, DRSCL, XERBLA + EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX @@ -150,7 +154,7 @@ END IF KASE = 0 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN *
--- a/libcruft/lapack/dtrevc.f +++ b/libcruft/lapack/dtrevc.f @@ -1,10 +1,9 @@ SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -21,28 +20,23 @@ * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. -* +* Matrices of this type are produced by the Schur factorization of +* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input orthogonal -* matrix. If T was obtained from the real-Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. -* -* T must be in Schur canonical form (as returned by DHSEQR), that is, -* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each -* 2-by-2 diagonal block has its diagonal elements equal and its -* off-diagonal elements of opposite sign. Corresponding to each 2-by-2 -* diagonal block is a complex conjugate pair of eigenvalues and -* eigenvectors; only one eigenvector of the pair is computed, namely -* the one corresponding to the eigenvalue with positive imaginary part. +* +* T*x = w*x, (y**H)*T = w*(y**H) +* +* where y**H denotes the conjugate transpose of y. +* The eigenvalues are not input to this routine, but are read directly +* from the diagonal blocks of T. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +* input matrix. If Q is the orthogonal factor that reduces a matrix +* A to Schur form T, then Q*X and Q*Y are the matrices of right and +* left eigenvectors of A. * * Arguments * ========= @@ -55,21 +49,21 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to a real -* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be -* set to .TRUE.; then on exit SELECT(j) is .TRUE. and -* SELECT(j+1) is .FALSE.. +* If w(j) is a real eigenvalue, the corresponding real +* eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector is +* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +* .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. @@ -86,15 +80,6 @@ * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL has the same quasi-lower triangular form -* as T'. If T(i,i) is a real eigenvalue, then -* the i-th column VL(i) of VL is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VL(i)+sqrt(-1)*VL(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -103,11 +88,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -115,15 +100,6 @@ * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR has the same quasi-upper triangular form -* as T. If T(i,i) is a real eigenvalue, then -* the i-th column VR(i) of VR is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VR(i)+sqrt(-1)*VR(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -132,11 +108,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* The leading dimension of the array VR. LDVR >= 1, and if +* SIDE = 'R' or 'B', LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. @@ -940,7 +916,6 @@ * * Copy the vector x or Q*x to VL and normalize. * - 210 CONTINUE IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
--- a/libcruft/lapack/dtrexc.f +++ b/libcruft/lapack/dtrexc.f @@ -1,10 +1,9 @@ SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ
--- a/libcruft/lapack/dtrsen.f +++ b/libcruft/lapack/dtrsen.f @@ -1,10 +1,9 @@ SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -112,27 +111,27 @@ * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= max(1,N); -* if JOB = 'E', LWORK >= M*(N-M); -* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). +* if JOB = 'E', LWORK >= max(1,M*(N-M)); +* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * -* IWORK (workspace) INTEGER array, dimension (LIWORK) -* IF JOB = 'N' or 'E', IWORK is not referenced. +* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) +* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * If JOB = 'N' or 'E', LIWORK >= 1; -* if JOB = 'V' or 'B', LIWORK >= M*(N-M). +* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). * * If LIWORK = -1, then a workspace query is assumed; the * routine only calculates the optimal size of the IWORK array, @@ -233,13 +232,16 @@ $ NN DOUBLE PRECISION EST, RNORM, SCALE * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE EXTERNAL LSAME, DLANGE * .. * .. External Subroutines .. - EXTERNAL DLACON, DLACPY, DTREXC, DTRSYL, XERBLA + EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT @@ -408,7 +410,7 @@ EST = ZERO KASE = 0 30 CONTINUE - CALL DLACON( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE ) + CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN *
--- a/libcruft/lapack/dtrsyl.f +++ b/libcruft/lapack/dtrsyl.f @@ -1,10 +1,9 @@ SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB @@ -111,7 +110,7 @@ EXTERNAL LSAME, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. - EXTERNAL DLALN2, DLASY2, DSCAL, XERBLA + EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN
--- a/libcruft/lapack/dtrti2.f +++ b/libcruft/lapack/dtrti2.f @@ -1,9 +1,8 @@ SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO
--- a/libcruft/lapack/dtrtri.f +++ b/libcruft/lapack/dtrtri.f @@ -1,9 +1,8 @@ SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO
--- a/libcruft/lapack/dtrtrs.f +++ b/libcruft/lapack/dtrtrs.f @@ -1,10 +1,9 @@ SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO
--- a/libcruft/lapack/dzsum1.f +++ b/libcruft/lapack/dzsum1.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
--- a/libcruft/lapack/ieeeck.f +++ b/libcruft/lapack/ieeeck.f @@ -1,9 +1,8 @@ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1998 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER ISPEC
--- a/libcruft/lapack/ilaenv.f +++ b/libcruft/lapack/ilaenv.f @@ -1,10 +1,8 @@ - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, - $ N4 ) + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* January 2007 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS @@ -18,6 +16,10 @@ * parameters for the local environment. See ISPEC for a description of * the parameters. * +* ILAENV returns an INTEGER +* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC +* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. +* * This version provides a set of parameters which should give good, * but not optimal, performance on many of the currently available * computers. Users are encouraged to modify this subroutine to set @@ -41,7 +43,7 @@ * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines +* eigenvalue routines (DEPRECATED) * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) @@ -50,13 +52,16 @@ * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors -* = 8: the crossover point for the multishift QR and QZ methods -* for nonsymmetric eigenvalue problems. +* = 8: the crossover point for the multishift QR method +* for nonsymmetric eigenvalue problems (DEPRECATED) * = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * =10: ieee NaN arithmetic can be trusted not to trap * =11: infinity arithmetic can be trusted not to trap +* 12 <= ISPEC <= 16: +* xHSEQR or one of its subroutines, +* see IPARMQ for detailed explanation * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or @@ -75,10 +80,6 @@ * Problem dimensions for the subroutine NAME; these may not all * be required. * -* (ILAENV) (output) INTEGER -* >= 0: the value of the parameter specified by ISPEC -* < 0: if ILAENV = -k, the k-th argument had an illegal value. -* * Further Details * =============== * @@ -102,49 +103,46 @@ * ===================================================================== * * .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. - INTEGER IEEECK - EXTERNAL IEEECK + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ * .. * .. Executable Statements .. * - GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, - $ 1100 ) ISPEC + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * - 100 CONTINUE + 10 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME - IC = ICHAR( SUBNAM( 1:1 ) ) + IC = ICHAR( SUBNAM( 1: 1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN @@ -154,14 +152,14 @@ IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1:1 ) = CHAR( IC+64 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) - $ SUBNAM( I:I ) = CHAR( IC+64 ) - 20 CONTINUE + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN @@ -169,27 +167,27 @@ * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE END IF END IF * - C1 = SUBNAM( 1:1 ) + C1 = SUBNAM( 1: 1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN - C2 = SUBNAM( 2:3 ) - C3 = SUBNAM( 4:6 ) - C4 = C3( 2:3 ) + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) * - GO TO ( 110, 200, 300 ) ISPEC + GO TO ( 50, 60, 70 )ISPEC * - 110 CONTINUE + 50 CONTINUE * * ISPEC = 1: block size * @@ -261,30 +259,30 @@ NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NB = 32 END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NB = 32 END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NB = 32 END IF END IF @@ -344,14 +342,14 @@ ILAENV = NB RETURN * - 200 CONTINUE + 60 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE @@ -391,30 +389,30 @@ NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NBMIN = 2 END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NBMIN = 2 END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NBMIN = 2 END IF END IF @@ -422,14 +420,14 @@ ILAENV = NBMIN RETURN * - 300 CONTINUE + 70 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE @@ -457,18 +455,18 @@ NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN NX = 128 END IF END IF @@ -476,42 +474,42 @@ ILAENV = NX RETURN * - 400 CONTINUE + 80 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * - 500 CONTINUE + 90 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * - 600 CONTINUE + 100 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * - 700 CONTINUE + 110 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * - 800 CONTINUE + 120 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * - 900 CONTINUE + 130 CONTINUE * * ISPEC = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm @@ -520,28 +518,35 @@ ILAENV = 25 RETURN * - 1000 CONTINUE + 140 CONTINUE * * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap * -C ILAENV = 0 +* ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) + ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN * - 1100 CONTINUE + 150 CONTINUE * * ISPEC = 11: infinity arithmetic can be trusted not to trap * -C ILAENV = 0 +* ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) + ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN * + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* * End of ILAENV * END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/iparmq.f @@ -0,0 +1,253 @@ + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* Purpose +* ======= +* +* This program sets problem and machine dependent parameters +* useful for xHSEQR and its subroutines. It is called whenever +* ILAENV is called with 12 <= ISPEC <= 16 +* +* Arguments +* ========= +* +* ISPEC (input) integer scalar +* ISPEC specifies which tunable parameter IPARMQ should +* return. +* +* ISPEC=12: (INMIN) Matrices of order nmin or less +* are sent directly to xLAHQR, the implicit +* double shift QR algorithm. NMIN must be +* at least 11. +* +* ISPEC=13: (INWIN) Size of the deflation window. +* This is best set greater than or equal to +* the number of simultaneous shifts NS. +* Larger matrices benefit from larger deflation +* windows. +* +* ISPEC=14: (INIBL) Determines when to stop nibbling and +* invest in an (expensive) multi-shift QR sweep. +* If the aggressive early deflation subroutine +* finds LD converged eigenvalues from an order +* NW deflation window and LD.GT.(NW*NIBBLE)/100, +* then the next QR sweep is skipped and early +* deflation is applied immediately to the +* remaining active diagonal block. Setting +* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +* multi-shift QR sweep whenever early deflation +* finds a converged eigenvalue. Setting +* IPARMQ(ISPEC=14) greater than or equal to 100 +* prevents TTQRE from skipping a multi-shift +* QR sweep. +* +* ISPEC=15: (NSHFTS) The number of simultaneous shifts in +* a multi-shift QR iteration. +* +* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +* following meanings. +* 0: During the multi-shift QR sweep, +* xLAQR5 does not accumulate reflections and +* does not use matrix-matrix multiply to +* update the far-from-diagonal matrix +* entries. +* 1: During the multi-shift QR sweep, +* xLAQR5 and/or xLAQRaccumulates reflections and uses +* matrix-matrix multiply to update the +* far-from-diagonal matrix entries. +* 2: During the multi-shift QR sweep. +* xLAQR5 accumulates reflections and takes +* advantage of 2-by-2 block structure during +* matrix-matrix multiplies. +* (If xTRMM is slower than xGEMM, then +* IPARMQ(ISPEC=16)=1 may be more efficient than +* IPARMQ(ISPEC=16)=2 despite the greater level of +* arithmetic work implied by the latter choice.) +* +* NAME (input) character string +* Name of the calling subroutine +* +* OPTS (input) character string +* This is a concatenation of the string arguments to +* TTQRE. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H. +* +* 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. +* +* LWORK (input) integer scalar +* The amount of workspace available. +* +* Further Details +* =============== +* +* Little is known about how best to choose these parameters. +* It is possible to use different values of the parameters +* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +* +* It is probably best to choose different parameters for +* different matrices and different parameters at different +* times during the iteration, but this has not been +* implemented --- yet. +* +* +* The best choices of most of the parameters depend +* in an ill-understood way on the relative execution +* rate of xLAQR3 and xLAQR5 and on the nature of each +* particular eigenvalue problem. Experiment may be the +* only practical way to determine which choices are most +* effective. +* +* Following is a list of default values supplied by IPARMQ. +* These defaults may be adjusted in order to attain better +* performance in any particular computational environment. +* +* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* IPARMQ(ISPEC=13) Recommended deflation window size. +* This depends on ILO, IHI and NS, the +* number of simultaneous shifts returned +* by IPARMQ(ISPEC=15). The default for +* (IHI-ILO+1).LE.500 is NS. The default +* for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +* +* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +* a multi-shift QR iteration. +* +* If IHI-ILO+1 is ... +* +* greater than ...but less ... the +* or equal to ... than default is +* +* 0 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 matrices of this order are +* passed to the implicit double shift routine +* xLAHQR. See IPARMQ(ISPEC=12) above. These +* values of NS are used only in case of a rare +* xLAHQR failure. +* +* (**) The asterisks (**) indicate an ad-hoc +* function increasing from 10 to 64. +* +* IPARMQ(ISPEC=16) Select structured matrix multiply. +* (See ISPEC=16 above for details.) +* Default: 3. +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END
--- a/libcruft/lapack/izmax1.f +++ b/libcruft/lapack/izmax1.f @@ -1,9 +1,8 @@ INTEGER FUNCTION IZMAX1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N @@ -43,7 +42,7 @@ COMPLEX*16 ZDUM * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE + INTRINSIC ABS * .. * .. Statement Functions .. DOUBLE PRECISION CABS1
--- a/libcruft/lapack/spotf2.f +++ b/libcruft/lapack/spotf2.f @@ -1,9 +1,8 @@ SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/spotrf.f +++ b/libcruft/lapack/spotrf.f @@ -1,9 +1,8 @@ SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zbdsqr.f +++ b/libcruft/lapack/zbdsqr.f @@ -1,10 +1,9 @@ SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO @@ -18,14 +17,26 @@ * Purpose * ======= * -* ZBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given complex input matrices U, VT, and C. +* ZBDSQR computes the singular values and, optionally, the right and/or +* left singular vectors from the singular value decomposition (SVD) of +* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit +* zero-shift QR algorithm. The SVD of B has the form +* +* B = Q * S * P**H +* +* where S is the diagonal matrix of singular values, Q is an orthogonal +* matrix of left singular vectors, and P is an orthogonal matrix of +* right singular vectors. If left singular vectors are requested, this +* subroutine actually returns U*Q instead of Q, and, if right singular +* vectors are requested, this subroutine returns P**H*VT instead of +* P**H, for given complex input matrices U and VT. When U and VT are +* the unitary matrices that reduce a general matrix A to bidiagonal +* form: A = U*B*VT, as computed by ZGEBRD, then +* +* A = (U*Q) * S * (P**H*VT) +* +* is the SVD of A. Optionally, the subroutine may also compute Q**H*C +* for a given complex input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, @@ -60,19 +71,18 @@ * On exit, if INFO=0, the singular values of B in decreasing * order. * -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* E (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, the N-1 offdiagonal elements of the bidiagonal +* matrix B. +* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given -* as input. E(N) is used for workspace. +* as input. * * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**H * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -81,21 +91,22 @@ * U (input/output) COMPLEX*16 array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) COMPLEX*16 array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* On exit, C is overwritten by Q**H * C. +* Not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * -* RWORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit @@ -155,7 +166,7 @@ $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, - $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, + $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. @@ -415,7 +426,6 @@ E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 100 CONTINUE @@ -444,7 +454,6 @@ E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 110 CONTINUE
--- a/libcruft/lapack/zdrscl.f +++ b/libcruft/lapack/zdrscl.f @@ -1,9 +1,8 @@ SUBROUTINE ZDRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
--- a/libcruft/lapack/zgbcon.f +++ b/libcruft/lapack/zgbcon.f @@ -1,10 +1,11 @@ SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM @@ -89,6 +90,9 @@ DOUBLE PRECISION AINVNM, SCALE, SMLNUM COMPLEX*16 T, ZDUM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX @@ -97,7 +101,7 @@ EXTERNAL LSAME, IZAMAX, DLAMCH, ZDOTC * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZDRSCL, ZLACON, ZLATBS + EXTERNAL XERBLA, ZAXPY, ZDRSCL, ZLACN2, ZLATBS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MIN @@ -157,7 +161,7 @@ LNOTI = KL.GT.0 KASE = 0 10 CONTINUE - CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN *
--- a/libcruft/lapack/zgbtf2.f +++ b/libcruft/lapack/zgbtf2.f @@ -1,9 +1,8 @@ SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N
--- a/libcruft/lapack/zgbtrf.f +++ b/libcruft/lapack/zgbtrf.f @@ -1,9 +1,8 @@ SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N
--- a/libcruft/lapack/zgbtrs.f +++ b/libcruft/lapack/zgbtrs.f @@ -1,10 +1,9 @@ SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANS
--- a/libcruft/lapack/zgebak.f +++ b/libcruft/lapack/zgebak.f @@ -1,10 +1,9 @@ SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE
--- a/libcruft/lapack/zgebal.f +++ b/libcruft/lapack/zgebal.f @@ -1,9 +1,8 @@ SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOB @@ -106,7 +105,7 @@ DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 0.8D+1 ) + PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * ..
--- a/libcruft/lapack/zgebd2.f +++ b/libcruft/lapack/zgebd2.f @@ -1,9 +1,8 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -172,8 +171,9 @@ * * Apply H(i)' to A(i:m,i+1:n) from the left * - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) + IF( I.LT.N ) + $ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN @@ -215,8 +215,9 @@ * * Apply G(i) to A(i+1:m,i:n) from the right * - CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) + IF( I.LT.M ) + $ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) *
--- a/libcruft/lapack/zgebrd.f +++ b/libcruft/lapack/zgebrd.f @@ -1,10 +1,9 @@ SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -70,7 +69,7 @@ * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zgecon.f +++ b/libcruft/lapack/zgecon.f @@ -1,10 +1,11 @@ SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM @@ -75,6 +76,9 @@ DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU COMPLEX*16 ZDUM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX @@ -82,7 +86,7 @@ EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS + EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX @@ -136,7 +140,7 @@ END IF KASE = 0 10 CONTINUE - CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN *
--- a/libcruft/lapack/zgeesx.f +++ b/libcruft/lapack/zgeesx.f @@ -2,10 +2,9 @@ $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -56,7 +55,7 @@ * = 'N': Eigenvalues are not ordered; * = 'S': Eigenvalues are ordered (see SELECT). * -* SELECT (input) LOGICAL FUNCTION of one COMPLEX*16 argument +* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument * SELECT must be declared EXTERNAL in the calling subroutine. * If SORT = 'S', SELECT is used to select eigenvalues to order * to the top left of the Schur form. @@ -109,16 +108,24 @@ * condition number for the selected right invariant subspace. * Not referenced if SENSE = 'N' or 'E'. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,2*N). * Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), * where SDIM is the number of selected eigenvalues computed by -* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. +* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also +* that an error is only returned if LWORK < max(1,2*N), but if +* SENSE = 'E' or 'V' or 'B' this may not be large enough. * For good performance, LWORK must generally be larger. * +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates upper bound on the optimal size of the +* array WORK, returns this value as the first entry of the WORK +* array, and no error message related to LWORK is issued by +* XERBLA. +* * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * BWORK (workspace) LOGICAL array, dimension (N) @@ -151,15 +158,15 @@ LOGICAL SCALEA, WANTSB, WANTSE, WANTSN, WANTST, WANTSV, $ WANTVS INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, - $ ITAU, IWRK, K, MAXB, MAXWRK, MINWRK + $ ITAU, IWRK, LWRK, MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, - $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR + EXTERNAL DLABAD, DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, + $ ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -168,7 +175,7 @@ EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT + INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * @@ -210,30 +217,36 @@ * depends on SDIM, which is computed by the routine ZTRSEN later * in the code.) * - MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 ) ) THEN - MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) - MINWRK = MAX( 1, 2*N ) - IF( .NOT.WANTVS ) THEN - MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SN', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SN', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, HSWORK, 1 ) + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + LWRK = 1 ELSE - MAXWRK = MAX( MAXWRK, N+( N-1 )* - $ ILAENV( 1, 'ZUNGHR', ' ', N, 1, N, -1 ) ) - MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SV', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SV', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, HSWORK, 1 ) + MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 2*N +* + CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS, + $ WORK, -1, IEVAL ) + HSWORK = WORK( 1 ) +* + IF( .NOT.WANTVS ) THEN + MAXWRK = MAX( MAXWRK, HSWORK ) + ELSE + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + MAXWRK = MAX( MAXWRK, HSWORK ) + END IF + LWRK = MAXWRK + IF( .NOT.WANTSN ) + $ LWRK = MAX( LWRK, ( N*N )/2 ) END IF - WORK( 1 ) = MAXWRK + WORK( 1 ) = LWRK +* + IF( LWORK.LT.MINWRK ) THEN + INFO = -15 + END IF END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -15 - END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEESX', -INFO ) RETURN
--- a/libcruft/lapack/zgeev.f +++ b/libcruft/lapack/zgeev.f @@ -1,10 +1,9 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -78,7 +77,7 @@ * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -110,7 +109,7 @@ LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, - $ IWRK, K, MAXB, MAXWRK, MINWRK, NOUT + $ IWRK, K, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM COMPLEX*16 TMP * .. @@ -119,8 +118,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, ZHSEQR, - $ ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR + EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -129,7 +128,7 @@ EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN, SQRT + INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT * .. * .. Executable Statements .. * @@ -164,31 +163,37 @@ * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * - MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN - MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) - IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN - MINWRK = MAX( 1, 2*N ) - MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'EN', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'EN', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, HSWORK ) + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 ELSE - MINWRK = MAX( 1, 2*N ) - MAXWRK = MAX( MAXWRK, N+( N-1 )* - $ ILAENV( 1, 'ZUNGHR', ' ', N, 1, N, -1 ) ) - MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SV', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SV', N, 1, - $ N, -1 ) ) ) - HSWORK = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, HSWORK, 2*N ) + MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 2*N + IF( WANTVL ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, + $ WORK, -1, INFO ) + ELSE IF( WANTVR ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + ELSE + CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + END IF + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) END IF WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEEV ', -INFO ) RETURN
--- a/libcruft/lapack/zgehd2.f +++ b/libcruft/lapack/zgehd2.f @@ -1,9 +1,8 @@ SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N
--- a/libcruft/lapack/zgehrd.f +++ b/libcruft/lapack/zgehrd.f @@ -1,22 +1,21 @@ SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * -* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H -* by a unitary similarity transformation: Q' * A * Q = H . +* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by +* an unitary similarity transformation: Q' * A * Q = H . * * Arguments * ========= @@ -98,26 +97,31 @@ * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * +* This file is a slight modification of LAPACK-3.0's ZGEHRD +* subroutine incorporating improvements proposed by Quintana-Orti and +* Van de Geijn (2005). +* * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, - $ NH, NX - COMPLEX*16 EI + INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + COMPLEX*16 EI * .. * .. Local Arrays .. - COMPLEX*16 T( LDT, NBMAX ) + COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZGEHD2, ZGEMM, ZLAHRD, ZLARFB + EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, + $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -170,24 +174,27 @@ RETURN END IF * +* Determine the block size +* + NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IWS = 1 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). +* (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * -* Determine if workspace is large enough for blocked code. +* Determine if workspace is large enough for blocked code * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of -* unblocked code. +* unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, $ -1 ) ) @@ -211,35 +218,47 @@ * * Use blocked code * - DO 30 I = ILO, IHI - 1 - NX, NB + DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * - CALL ZLAHRD( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, + CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set -* to 1. +* to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE - CALL ZGEMM( 'No transpose', 'Conjugate transpose', IHI, - $ IHI-I-IB+1, IB, -ONE, WORK, LDWORK, - $ A( I+IB, I ), LDA, ONE, A( 1, I+IB ), LDA ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ IHI, IHI-I-IB+1, + $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, + $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE +* * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', - $ 'Columnwise', IHI-I, N-I-IB+1, IB, A( I+1, I ), - $ LDA, T, LDT, A( I+1, I+IB ), LDA, WORK, - $ LDWORK ) - 30 CONTINUE + $ 'Columnwise', + $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, + $ A( I+1, I+IB ), LDA, WORK, LDWORK ) + 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix
--- a/libcruft/lapack/zgelq2.f +++ b/libcruft/lapack/zgelq2.f @@ -1,9 +1,8 @@ SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N
--- a/libcruft/lapack/zgelqf.f +++ b/libcruft/lapack/zgelqf.f @@ -1,9 +1,8 @@ SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -42,7 +41,7 @@ * The scalar factors of the elementary reflectors (see Further * Details). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zgelss.f +++ b/libcruft/lapack/zgelss.f @@ -1,10 +1,9 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -61,7 +60,7 @@ * On exit, B is overwritten by the N-by-NRHS solution matrix X. * If m >= n and RANK = n, the residual sum-of-squares for * the solution in the i-th column is given by the sum of -* squares of elements n+1:m in that column. +* squares of the modulus of elements n+1:m in that column. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M,N). @@ -79,7 +78,7 @@ * The effective rank of A, i.e., the number of singular values * which are greater than RCOND*S(1). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -141,7 +140,6 @@ INFO = 0 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) - MNTHR = ILAENV( 6, 'ZGELSS', ' ', M, N, NRHS, -1 ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 @@ -163,82 +161,79 @@ * to real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * - MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN - MAXWRK = 0 - MM = M - IF( M.GE.N .AND. M.GE.MNTHR ) THEN + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( MINMN.GT.0 ) THEN + MM = M + MNTHR = ILAENV( 6, 'ZGELSS', ' ', M, N, NRHS, -1 ) + IF( M.GE.N .AND. M.GE.MNTHR ) THEN * -* Path 1a - overdetermined, with many more rows than columns -* -* Space needed for ZBDSQR is BDSPAC = 5*N +* Path 1a - overdetermined, with many more rows than +* columns * - MM = N - MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'ZGEQRF', ' ', M, N, - $ -1, -1 ) ) - MAXWRK = MAX( MAXWRK, N+NRHS* - $ ILAENV( 1, 'ZUNMQR', 'LC', M, NRHS, N, -1 ) ) - END IF - IF( M.GE.N ) THEN + MM = N + MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'ZGEQRF', ' ', M, + $ N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'ZUNMQR', 'LC', + $ M, NRHS, N, -1 ) ) + END IF + IF( M.GE.N ) THEN * -* Path 1 - overdetermined or exactly determined -* -* Space needed for ZBDSQR is BDSPC = 7*N+12 +* Path 1 - overdetermined or exactly determined * - MAXWRK = MAX( MAXWRK, 2*N+( MM+N )* - $ ILAENV( 1, 'ZGEBRD', ' ', MM, N, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+NRHS* - $ ILAENV( 1, 'ZUNMBR', 'QLC', MM, NRHS, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - MINWRK = 2*N + MAX( NRHS, M ) - END IF - IF( N.GT.M ) THEN - MINWRK = 2*M + MAX( NRHS, N ) - IF( N.GE.MNTHR ) THEN + MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1, + $ 'ZGEBRD', ' ', MM, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'ZUNMBR', + $ 'QLC', MM, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'ZUNGBR', 'P', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, N*NRHS ) + MINWRK = 2*N + MAX( NRHS, M ) + END IF + IF( N.GT.M ) THEN + MINWRK = 2*M + MAX( NRHS, N ) + IF( N.GE.MNTHR ) THEN * -* Path 2a - underdetermined, with many more columns -* than rows -* -* Space needed for ZBDSQR is BDSPAC = 5*M +* Path 2a - underdetermined, with many more columns +* than rows * - MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, 3*M+M*M+2*M* - $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+M*M+NRHS* - $ ILAENV( 1, 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+M*M+( M-1 )* - $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) - IF( NRHS.GT.1 ) THEN - MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) + MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 3*M + M*M + 2*M*ILAENV( 1, + $ 'ZGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M + M*M + NRHS*ILAENV( 1, + $ 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M + M*M + ( M - 1 )*ILAENV( 1, + $ 'ZUNGBR', 'P', M, M, M, -1 ) ) + IF( NRHS.GT.1 ) THEN + MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) + ELSE + MAXWRK = MAX( MAXWRK, M*M + 2*M ) + END IF + MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'ZUNMLQ', + $ 'LC', N, NRHS, M, -1 ) ) ELSE - MAXWRK = MAX( MAXWRK, M*M+2*M ) +* +* Path 2 - underdetermined +* + MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'ZGEBRD', ' ', M, + $ N, -1, -1 ) + MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'ZUNMBR', + $ 'QLC', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'ZUNGBR', + $ 'P', M, N, M, -1 ) ) + MAXWRK = MAX( MAXWRK, N*NRHS ) END IF - MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M, -1 ) ) - ELSE -* -* Path 2 - underdetermined -* -* Space needed for ZBDSQR is BDSPAC = 5*M + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF + WORK( 1 ) = MAXWRK * - MAXWRK = 2*M + ( N+M )*ILAENV( 1, 'ZGEBRD', ' ', M, N, - $ -1, -1 ) - MAXWRK = MAX( MAXWRK, 2*M+NRHS* - $ ILAENV( 1, 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 2*M+M* - $ ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - END IF - END IF - MINWRK = MAX( MINWRK, 1 ) - MAXWRK = MAX( MINWRK, MAXWRK ) - WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELSS', -INFO ) RETURN
--- a/libcruft/lapack/zgeqpf.f +++ b/libcruft/lapack/zgeqpf.f @@ -1,9 +1,8 @@ SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK deprecated driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -78,6 +77,12 @@ * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * +* Partial column norm updating strategy modified by +* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, +* University of Zagreb, Croatia. +* June 2006. +* For more details see LAPACK Working Note 176. +* * ===================================================================== * * .. Parameters .. @@ -86,7 +91,7 @@ * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT - DOUBLE PRECISION TEMP, TEMP2 + DOUBLE PRECISION TEMP, TEMP2, TOL3Z COMPLEX*16 AII * .. * .. External Subroutines .. @@ -97,8 +102,8 @@ * .. * .. External Functions .. INTEGER IDAMAX - DOUBLE PRECISION DZNRM2 - EXTERNAL IDAMAX, DZNRM2 + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL IDAMAX, DLAMCH, DZNRM2 * .. * .. Executable Statements .. * @@ -118,6 +123,7 @@ END IF * MN = MIN( M, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) * * Move initial columns up front * @@ -198,11 +204,14 @@ * DO 30 J = I + 1, N IF( RWORK( J ).NE.ZERO ) THEN - TEMP = ONE - ( ABS( A( I, J ) ) / RWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + 0.05D0*TEMP* - $ ( RWORK( J ) / RWORK( N+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / RWORK( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J )
--- a/libcruft/lapack/zgeqr2.f +++ b/libcruft/lapack/zgeqr2.f @@ -1,9 +1,8 @@ SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N
--- a/libcruft/lapack/zgeqrf.f +++ b/libcruft/lapack/zgeqrf.f @@ -1,9 +1,8 @@ SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N @@ -43,7 +42,7 @@ * The scalar factors of the elementary reflectors (see Further * Details). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zgesv.f +++ b/libcruft/lapack/zgesv.f @@ -1,9 +1,8 @@ SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS
--- a/libcruft/lapack/zgesvd.f +++ b/libcruft/lapack/zgesvd.f @@ -1,10 +1,9 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -106,12 +105,12 @@ * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1. -* LWORK >= 2*MIN(M,N)+MAX(M,N). +* The dimension of the array WORK. +* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine @@ -176,7 +175,6 @@ * INFO = 0 MINMN = MIN( M, N ) - MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) WNTUA = LSAME( JOBU, 'A' ) WNTUS = LSAME( JOBU, 'S' ) WNTUAS = WNTUA .OR. WNTUS @@ -187,7 +185,6 @@ WNTVAS = WNTVA .OR. WNTVS WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) - MINWRK = 1 LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN @@ -216,12 +213,14 @@ * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. - $ N.GT.0 ) THEN - IF( M.GE.N ) THEN + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*N * + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN * @@ -235,7 +234,6 @@ $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MINWRK = 3*N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') @@ -249,7 +247,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or @@ -266,7 +263,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') @@ -280,7 +276,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') @@ -296,7 +291,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = 2*N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or @@ -313,7 +307,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') @@ -327,7 +320,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') @@ -343,7 +335,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = 2*N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or @@ -360,7 +351,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) END IF ELSE * @@ -378,12 +368,12 @@ $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) END IF - ELSE + ELSE IF( MINMN.GT.0 ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*M * + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * @@ -397,7 +387,6 @@ $ MAXWRK = MAX( MAXWRK, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MINWRK = 3*M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') @@ -411,7 +400,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', @@ -428,7 +416,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') @@ -442,7 +429,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') @@ -458,7 +444,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = 2*M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', @@ -475,7 +460,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') @@ -489,7 +473,6 @@ $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') @@ -505,7 +488,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = 2*M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', @@ -522,7 +504,6 @@ $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) END IF ELSE * @@ -540,15 +521,16 @@ $ MAXWRK = MAX( MAXWRK, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) END IF END IF + MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVD', -INFO ) RETURN @@ -559,8 +541,6 @@ * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * @@ -823,8 +803,9 @@ * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), - $ LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) @@ -904,8 +885,9 @@ * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), - $ LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (CWorkspace: need 2*N, prefer N+N*NB) @@ -1407,8 +1389,9 @@ * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ VT( 2, 1 ), LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N @@ -1921,8 +1904,9 @@ * Copy R from A to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, - $ VT( 2, 1 ), LDVT ) + IF( N.GT.1 ) + $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, + $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N
--- a/libcruft/lapack/zgetf2.f +++ b/libcruft/lapack/zgetf2.f @@ -1,9 +1,8 @@ SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -64,11 +63,13 @@ $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER J, JP + DOUBLE PRECISION SFMIN + INTEGER I, J, JP * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH INTEGER IZAMAX - EXTERNAL IZAMAX + EXTERNAL DLAMCH, IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP @@ -98,6 +99,10 @@ IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. @@ -113,8 +118,15 @@ * * Compute elements J+1:M of J-th column. * - IF( J.LT.M ) - $ CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF * ELSE IF( INFO.EQ.0 ) THEN *
--- a/libcruft/lapack/zgetrf.f +++ b/libcruft/lapack/zgetrf.f @@ -1,9 +1,8 @@ SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N
--- a/libcruft/lapack/zgetri.f +++ b/libcruft/lapack/zgetri.f @@ -1,9 +1,8 @@ SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N @@ -40,7 +39,7 @@ * The pivot indices from ZGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO=0, then WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zgetrs.f +++ b/libcruft/lapack/zgetrs.f @@ -1,9 +1,8 @@ SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANS
--- a/libcruft/lapack/zggbal.f +++ b/libcruft/lapack/zggbal.f @@ -1,10 +1,9 @@ SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOB @@ -88,7 +87,9 @@ * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * -* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) +* WORK (workspace) REAL array, dimension (lwork) +* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and +* at least 1 when JOB = 'N' or 'P'. * * INFO (output) INTEGER * = 0: successful exit @@ -150,20 +151,28 @@ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 + INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAL', -INFO ) RETURN END IF * - K = 1 - L = N -* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN + ILO = 1 + IHI = N + RETURN + END IF +* + IF( N.EQ.1 ) THEN + ILO = 1 + IHI = N + LSCALE( 1 ) = ONE + RSCALE( 1 ) = ONE + RETURN + END IF * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 @@ -175,14 +184,8 @@ RETURN END IF * - IF( K.EQ.L ) THEN - ILO = 1 - IHI = 1 - LSCALE( 1 ) = ONE - RSCALE( 1 ) = ONE - RETURN - END IF -* + K = 1 + L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * @@ -278,12 +281,17 @@ ILO = K IHI = L * + IF( LSAME( JOB, 'P' ) ) THEN + DO 195 I = ILO, IHI + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 195 CONTINUE + RETURN + END IF +* IF( ILO.EQ.IHI ) $ RETURN * - IF( LSAME( JOB, 'P' ) ) - $ RETURN -* * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 @@ -437,7 +445,7 @@ DO 360 I = ILO, IHI IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) - IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDA ) + IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
--- a/libcruft/lapack/zgtsv.f +++ b/libcruft/lapack/zgtsv.f @@ -1,9 +1,8 @@ SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS
--- a/libcruft/lapack/zgttrf.f +++ b/libcruft/lapack/zgttrf.f @@ -1,9 +1,8 @@ SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, N @@ -29,28 +28,31 @@ * ========= * * N (input) INTEGER -* The order of the matrix A. N >= 0. +* The order of the matrix A. * * DL (input/output) COMPLEX*16 array, dimension (N-1) -* On entry, DL must contain the (n-1) subdiagonal elements of +* On entry, DL must contain the (n-1) sub-diagonal elements of * A. +* * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) COMPLEX*16 array, dimension (N) * On entry, D must contain the diagonal elements of A. +* * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) COMPLEX*16 array, dimension (N-1) -* On entry, DU must contain the (n-1) superdiagonal elements +* On entry, DU must contain the (n-1) super-diagonal elements * of A. +* * On exit, DU is overwritten by the (n-1) elements of the first -* superdiagonal of U. +* super-diagonal of U. * * DU2 (output) COMPLEX*16 array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the -* second superdiagonal of U. +* second super-diagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was @@ -60,27 +62,27 @@ * * INFO (output) INTEGER * = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. * .. Local Scalars .. INTEGER I COMPLEX*16 FACT, TEMP, ZDUM * .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG -* .. * .. External Subroutines .. EXTERNAL XERBLA * .. -* .. Parameters .. - COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 @@ -102,30 +104,25 @@ IF( N.EQ.0 ) $ RETURN * -* Initialize IPIV(i) = i +* Initialize IPIV(i) = i and DU2(i) = 0 * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE -* - DO 20 I = 1, N - 1 - IF( DL( I ).EQ.CZERO ) THEN -* -* Subdiagonal is zero, no elimination is required. + DO 20 I = 1, N - 2 + DU2( I ) = ZERO + 20 CONTINUE * - IF( D( I ).EQ.CZERO .AND. INFO.EQ.0 ) - $ INFO = I - IF( I.LT.N-1 ) - $ DU2( I ) = CZERO - ELSE IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN + DO 30 I = 1, N - 2 + IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * - FACT = DL( I ) / D( I ) - DL( I ) = FACT - D( I+1 ) = D( I+1 ) - FACT*DU( I ) - IF( I.LT.N-1 ) - $ DU2( I ) = CZERO + IF( CABS1( D( I ) ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + DL( I ) = FACT + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + END IF ELSE * * Interchange rows I and I+1, eliminate DL(I) @@ -136,18 +133,40 @@ TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) - IF( I.LT.N-1 ) THEN - DU2( I ) = DU( I+1 ) - DU( I+1 ) = -FACT*DU( I+1 ) - END IF - IPIV( I ) = IPIV( I ) + 1 + DU2( I ) = DU( I+1 ) + DU( I+1 ) = -FACT*DU( I+1 ) + IPIV( I ) = I + 1 END IF - 20 CONTINUE - IF( D( N ).EQ.CZERO .AND. INFO.EQ.0 ) THEN - INFO = N - RETURN + 30 CONTINUE + IF( N.GT.1 ) THEN + I = N - 1 + IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN + IF( CABS1( D( I ) ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + DL( I ) = FACT + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + END IF + ELSE + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + DL( I ) = FACT + TEMP = DU( I ) + DU( I ) = D( I+1 ) + D( I+1 ) = TEMP - FACT*D( I+1 ) + IPIV( I ) = I + 1 + END IF END IF * +* Check for a zero on the diagonal of U. +* + DO 40 I = 1, N + IF( CABS1( D( I ) ).EQ.ZERO ) THEN + INFO = I + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE +* RETURN * * End of ZGTTRF
--- a/libcruft/lapack/zgttrs.f +++ b/libcruft/lapack/zgttrs.f @@ -1,10 +1,9 @@ SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANS @@ -26,14 +25,14 @@ * Arguments * ========= * -* TRANS (input) CHARACTER -* Specifies the form of the system of equations: +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations. * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose) * * N (input) INTEGER -* The order of the matrix A. N >= 0. +* The order of the matrix A. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns @@ -48,10 +47,10 @@ * the LU factorization of A. * * DU (input) COMPLEX*16 array, dimension (N-1) -* The (n-1) elements of the first superdiagonal of U. +* The (n-1) elements of the first super-diagonal of U. * * DU2 (input) COMPLEX*16 array, dimension (N-2) -* The (n-2) elements of the second superdiagonal of U. +* The (n-2) elements of the second super-diagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was @@ -60,39 +59,38 @@ * required. * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, B is overwritten by the solution matrix X. +* On entry, the matrix of right hand side vectors B. +* On exit, B is overwritten by the solution vectors X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value +* < 0: if INFO = -k, the k-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN - INTEGER I, J - COMPLEX*16 TEMP + INTEGER ITRANS, J, JB, NB * .. * .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV * .. * .. External Subroutines .. - EXTERNAL XERBLA + EXTERNAL XERBLA, ZGTTS2 * .. * .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX + INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN + NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) + IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. + $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 @@ -111,94 +109,32 @@ IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * - IF( NOTRAN ) THEN -* -* Solve A*X = B using the LU factorization of A, -* overwriting each right hand side vector with its solution. -* - DO 30 J = 1, NRHS -* -* Solve L*x = b. -* - DO 10 I = 1, N - 1 - IF( IPIV( I ).EQ.I ) THEN - B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) - ELSE - TEMP = B( I, J ) - B( I, J ) = B( I+1, J ) - B( I+1, J ) = TEMP - DL( I )*B( I, J ) - END IF - 10 CONTINUE +* Decode TRANS * -* Solve U*x = b. + IF( NOTRAN ) THEN + ITRANS = 0 + ELSE IF( TRANS.EQ.'T' .OR. TRANS.EQ.'t' ) THEN + ITRANS = 1 + ELSE + ITRANS = 2 + END IF * - B( N, J ) = B( N, J ) / D( N ) - IF( N.GT.1 ) - $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / - $ D( N-1 ) - DO 20 I = N - 2, 1, -1 - B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* - $ B( I+2, J ) ) / D( I ) - 20 CONTINUE - 30 CONTINUE - ELSE IF( LSAME( TRANS, 'T' ) ) THEN -* -* Solve A**T * X = B. -* - DO 60 J = 1, NRHS -* -* Solve U**T * x = b. +* Determine the number of right-hand sides to solve at a time. * - B( 1, J ) = B( 1, J ) / D( 1 ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) - DO 40 I = 3, N - B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* - $ B( I-2, J ) ) / D( I ) - 40 CONTINUE -* -* Solve L**T * x = b. -* - DO 50 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DL( I )*TEMP - B( I, J ) = TEMP - END IF - 50 CONTINUE - 60 CONTINUE + IF( NRHS.EQ.1 ) THEN + NB = 1 ELSE -* -* Solve A**H * X = B. + NB = MAX( 1, ILAENV( 1, 'ZGTTRS', TRANS, N, NRHS, -1, -1 ) ) + END IF * - DO 90 J = 1, NRHS -* -* Solve U**H * x = b. -* - B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) ) - IF( N.GT.1 ) - $ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) / - $ DCONJG( D( 2 ) ) - DO 70 I = 3, N - B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*B( I-1, J )- - $ DCONJG( DU2( I-2 ) )*B( I-2, J ) ) / - $ DCONJG( D( I ) ) - 70 CONTINUE -* -* Solve L**H * x = b. -* - DO 80 I = N - 1, 1, -1 - IF( IPIV( I ).EQ.I ) THEN - B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*B( I+1, J ) - ELSE - TEMP = B( I+1, J ) - B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP - B( I, J ) = TEMP - END IF - 80 CONTINUE - 90 CONTINUE + IF( NB.GE.NRHS ) THEN + CALL ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) + ELSE + DO 10 J = 1, NRHS, NB + JB = MIN( NRHS-J+1, NB ) + CALL ZGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), + $ LDB ) + 10 CONTINUE END IF * * End of ZGTTRS
--- a/libcruft/lapack/zheev.f +++ b/libcruft/lapack/zheev.f @@ -1,10 +1,9 @@ SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -53,7 +52,7 @@ * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -86,7 +85,7 @@ * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LOPT, LWKOPT, NB + $ LLWORK, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. @@ -120,14 +119,15 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+1 )*N ) WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 END IF * IF( INFO.NE.0 ) THEN @@ -140,13 +140,12 @@ * Quick return if possible * IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) - WORK( 1 ) = 3 + WORK( 1 ) = 1 IF( WANTZ ) $ A( 1, 1 ) = CONE RETURN @@ -183,7 +182,6 @@ LLWORK = LWORK - INDWRK + 1 CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) - LOPT = N + WORK( INDWRK ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * ZUNGTR to generate the unitary matrix, then call ZSTEQR.
--- a/libcruft/lapack/zhetd2.f +++ b/libcruft/lapack/zhetd2.f @@ -1,9 +1,8 @@ SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zhetrd.f +++ b/libcruft/lapack/zhetrd.f @@ -1,9 +1,8 @@ SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO @@ -65,7 +64,7 @@ * The scalar factors of the elementary reflectors (see Further * Details). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zhseqr.f +++ b/libcruft/lapack/zhseqr.f @@ -1,159 +1,267 @@ SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- 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 - INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. +* Purpose +* ======= * -* Purpose -* ======= +* ZHSEQR 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. * -* ZHSEQR computes the eigenvalues of a complex upper 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. +* 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. * -* 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)*T*(QZ)**H. +* 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 ZGEBAL, and then passed to ZGEHRD +* when the matrix output by ZGEBAL 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. * -* Arguments -* ========= +* H (input/output) COMPLEX*16 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.) * -* JOB (input) CHARACTER*1 -* = 'E': compute eigenvalues only; -* = 'S': compute eigenvalues and the Schur form T. +* Unlike earlier versions of ZHSEQR, 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). * -* 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. +* W (output) COMPLEX*16 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). * -* N (input) INTEGER -* The order of the matrix H. N >= 0. +* Z (input/output) COMPLEX*16 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 ZUNGHR +* after the call to ZGEHRD 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*16 array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) returns an estimate of +* the optimal value for LWORK. * -* 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 ZGEBAL, and then passed to CGEHRD -* when the matrix output by ZGEBAL is reduced to Hessenberg -* form. Otherwise ILO and IHI should be set to 1 and N -* respectively. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +* 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 ZHSEQR does a workspace query. +* In this case, ZHSEQR 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. +* * -* H (input/output) COMPLEX*16 array, dimension (LDH,N) -* On entry, the upper Hessenberg matrix H. -* On exit, if JOB = 'S', H contains the upper triangular matrix -* T from the Schur decomposition (the Schur form). If -* JOB = 'E', the contents of H are unspecified on exit. +* INFO (output) INTEGER +* = 0: successful exit +* .LT. 0: if INFO = -i, the i-th argument had an illegal +* value +* .GT. 0: if INFO = i, ZHSEQR 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.) * -* LDH (input) INTEGER -* The leading dimension of the array H. LDH >= max(1,N). +* 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 * -* W (output) COMPLEX*16 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). +* (*) (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. * -* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) -* If COMPZ = 'N': Z is not referenced. -* If COMPZ = 'I': on entry, Z need not be set, and on exit, 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 Z contains Q*Z. -* Normally Q is the unitary matrix generated by ZUNGHR after -* the call to ZGEHRD which formed the Hessenberg matrix H. +* ================================================================ +* Default values supplied by +* ILAENV(ISPEC,'ZHSEQR',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 ZLAHQR vs ZLAQR0 crossover point. +* Default: 75. (Must be at least 11.) * -* LDZ (input) INTEGER -* The leading dimension of the array Z. -* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. +* 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. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* ISPEC=3: Nibble crossover point. (See ILAENV for +* details.) Default: 14% of deflation window +* size. * -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). +* 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 * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* 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 +* ZLAHQR 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. * -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, ZHSEQR failed to compute all the -* eigenvalues in a total of 30*(IHI-ILO+1) iterations; -* elements 1:ilo-1 and i+1:n of W contain those -* eigenvalues which have been successfully computed. +* 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 +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== * -* .. Parameters .. +* ==== NL allocates some local workspace to help small matrices +* . through a rare ZLAHQR 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*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION RZERO, RONE, CONST - PARAMETER ( RZERO = 0.0D+0, RONE = 1.0D+0, - $ CONST = 1.5D+0 ) - INTEGER NSMAX, LDS - PARAMETER ( NSMAX = 15, LDS = NSMAX ) + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) +* .. +* .. Local Arrays .. + COMPLEX*16 HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. + INTEGER KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ - INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L, - $ MAXB, NH, NR, NS, NV - DOUBLE PRECISION OVFL, RTEMP, SMLNUM, TST1, ULP, UNFL - COMPLEX*16 CDUM, TAU, TEMP -* .. -* .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) - COMPLEX*16 S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 ) * .. * .. External Functions .. + INTEGER ILAENV LOGICAL LSAME - INTEGER ILAENV, IZAMAX - DOUBLE PRECISION DLAMCH, DLAPY2, ZLANHS - EXTERNAL LSAME, ILAENV, IZAMAX, DLAMCH, DLAPY2, ZLANHS + EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLACPY, ZLAHQR, - $ ZLARFG, ZLARFX, ZLASET, ZSCAL + EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN -* .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. -* .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) + INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Executable Statements .. * -* Decode and test the input parameters +* ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) + LQUERY = LWORK.EQ.-1 * INFO = 0 - WORK( 1 ) = MAX( 1, N ) - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN @@ -166,309 +274,122 @@ 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 + 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( 'ZHSEQR', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF * -* Initialize Z, if necessary -* - IF( INITZ ) - $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -* -* Store the eigenvalues isolated by ZGEBAL. + ELSE IF( N.EQ.0 ) THEN * - DO 10 I = 1, ILO - 1 - W( I ) = H( I, I ) - 10 CONTINUE - DO 20 I = IHI + 1, N - W( I ) = H( I, I ) - 20 CONTINUE +* ==== Quick return in case N = 0; nothing to do. ==== * -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN - IF( ILO.EQ.IHI ) THEN - W( ILO ) = H( ILO, ILO ) RETURN - END IF -* -* Set rows and columns ILO to IHI to zero below the first -* subdiagonal. * - DO 40 J = ILO, IHI - 2 - DO 30 I = J + 2, N - H( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - NH = IHI - ILO + 1 + ELSE IF( LQUERY ) THEN +* +* ==== Quick return in case of a workspace query ==== * -* I1 and I2 are the indices of the first row and last column of H -* to which transformations must be applied. If eigenvalues only are -* being computed, I1 and I2 are re-set inside the main loop. -* - IF( WANTT ) THEN - I1 = 1 - I2 = N - ELSE - I1 = ILO - I2 = IHI - END IF -* -* Ensure that the subdiagonal elements are real. + CALL ZLAQR0( 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 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, + $ N ) ) ), RZERO ) + RETURN * - DO 50 I = ILO + 1, IHI - TEMP = H( I, I-1 ) - IF( DIMAG( TEMP ).NE.RZERO ) THEN - RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) ) - H( I, I-1 ) = RTEMP - TEMP = TEMP / RTEMP - IF( I2.GT.I ) - $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) - CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) - IF( I.LT.IHI ) - $ H( I+1, I ) = TEMP*H( I+1, I ) - IF( WANTZ ) - $ CALL ZSCAL( NH, TEMP, Z( ILO, I ), 1 ) - END IF - 50 CONTINUE + ELSE * -* Determine the order of the multi-shift QR algorithm to be used. +* ==== copy eigenvalues isolated by ZGEBAL ==== * - NS = ILAENV( 4, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) - MAXB = ILAENV( 8, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) - IF( NS.LE.1 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN -* -* Use the standard double-shift algorithm -* - CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, - $ LDZ, INFO ) - RETURN - END IF - MAXB = MAX( 2, MAXB ) - NS = MIN( NS, MAXB, NSMAX ) -* -* Now 1 < NS <= MAXB < NH. -* -* Set machine-dependent constants for the stopping criterion. -* If norm(H) <= sqrt(OVFL), overflow should not occur. + IF( ILO.GT.1 ) + $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) + IF( IHI.LT.N ) + $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) * - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = RONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( NH / ULP ) -* -* ITN is the total number of multiple-shift QR iterations allowed. -* - ITN = 30*NH +* ==== Initialize Z, if requested ==== * -* The main loop begins here. I is the loop index and decreases from -* IHI to ILO in steps of at most MAXB. Each iteration of the loop -* works with the active submatrix in rows and columns L to I. -* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or -* H(L,L-1) is negligible so that the matrix splits. -* - I = IHI - 60 CONTINUE - IF( I.LT.ILO ) - $ GO TO 180 + IF( INITZ ) + $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * -* Perform multiple-shift QR iterations on rows and columns ILO to I -* until a submatrix of order at most MAXB splits off at the bottom -* because a subdiagonal element has become negligible. -* - L = ILO - DO 160 ITS = 0, ITN -* -* Look for a single small subdiagonal element. +* ==== Quick return if possible ==== * - DO 70 K = I, L + 1, -1 - TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) - IF( TST1.EQ.RZERO ) - $ TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK ) - IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) ) - $ GO TO 80 - 70 CONTINUE - 80 CONTINUE - L = K - IF( L.GT.ILO ) THEN -* -* H(L,L-1) is negligible. -* - H( L, L-1 ) = ZERO + IF( ILO.EQ.IHI ) THEN + W( ILO ) = H( ILO, ILO ) + RETURN END IF * -* Exit from loop if a submatrix of order <= MAXB has split off. +* ==== ZLAHQR/ZLAQR0 crossover point ==== * - IF( L.GE.I-MAXB+1 ) - $ GO TO 170 -* -* Now the active submatrix is in rows and columns L to I. If -* eigenvalues only are being computed, only the active submatrix -* need be transformed. + NMIN = ILAENV( 1, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO, + $ IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) * - IF( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF -* - IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN +* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== * -* Exceptional shifts. -* - DO 90 II = I - NS + 1, I - W( II ) = CONST*( ABS( DBLE( H( II, II-1 ) ) )+ - $ ABS( DBLE( H( II, II ) ) ) ) - 90 CONTINUE + IF( N.GT.NMIN ) THEN + CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, + $ Z, LDZ, WORK, LWORK, INFO ) ELSE * -* Use eigenvalues of trailing submatrix of order NS as shifts. +* ==== Small matrix ==== +* + CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, + $ Z, LDZ, INFO ) +* + IF( INFO.GT.0 ) THEN +* +* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds +* . when ZLAHQR fails. ==== +* + KBOT = INFO +* + IF( N.GE.NL ) THEN +* +* ==== Larger matrices have enough subdiagonal scratch +* . space to call ZLAQR0 directly. ==== * - CALL ZLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S, - $ LDS ) - CALL ZLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS, - $ W( I-NS+1 ), 1, NS, Z, LDZ, IERR ) - IF( IERR.GT.0 ) THEN + CALL ZLAQR0( 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 ZLAQR0. Hence, +* . tiny matrices must be copied into a larger +* . array before calling ZLAQR0. ==== * -* If ZLAHQR failed to compute all NS eigenvalues, use the -* unconverged diagonal elements as the remaining shifts. -* - DO 100 II = 1, IERR - W( I-NS+II ) = S( II, II ) - 100 CONTINUE + CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) + HL( N+1, N ) = ZERO + CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), + $ NL ) + CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, + $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) + IF( WANTT .OR. INFO.NE.0 ) + $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) + END IF END IF END IF * -* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) -* where G is the Hessenberg submatrix H(L:I,L:I) and w is -* the vector of shifts (stored in W). The result is -* stored in the local array V. -* - V( 1 ) = ONE - DO 110 II = 2, NS + 1 - V( II ) = ZERO - 110 CONTINUE - NV = 1 - DO 130 J = I - NS + 1, I - CALL ZCOPY( NV+1, V, 1, VV, 1 ) - CALL ZGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), LDH, - $ VV, 1, -W( J ), V, 1 ) - NV = NV + 1 -* -* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, -* reset it to the unit vector. +* ==== Clear out the trash, if necessary. ==== * - ITEMP = IZAMAX( NV, V, 1 ) - RTEMP = CABS1( V( ITEMP ) ) - IF( RTEMP.EQ.RZERO ) THEN - V( 1 ) = ONE - DO 120 II = 2, NV - V( II ) = ZERO - 120 CONTINUE - ELSE - RTEMP = MAX( RTEMP, SMLNUM ) - CALL ZDSCAL( NV, RONE / RTEMP, V, 1 ) - END IF - 130 CONTINUE -* -* Multiple-shift QR step -* - DO 150 K = L, I - 1 -* -* The first iteration of this loop determines a reflection G -* from the vector V and applies it from left and right to H, -* thus creating a nonzero bulge below the subdiagonal. -* -* Each subsequent iteration determines a reflection G to -* restore the Hessenberg form in the (K-1)th column, and thus -* chases the bulge one step toward the bottom of the active -* submatrix. NR is the order of G. -* - NR = MIN( NS+1, I-K+1 ) - IF( K.GT.L ) - $ CALL ZCOPY( NR, H( K, K-1 ), 1, V, 1 ) - CALL ZLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) - IF( K.GT.L ) THEN - H( K, K-1 ) = V( 1 ) - DO 140 II = K + 1, I - H( II, K-1 ) = ZERO - 140 CONTINUE - END IF - V( 1 ) = ONE -* -* Apply G' from the left to transform the rows of the matrix -* in columns K to I2. + IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) + $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * - CALL ZLARFX( 'Left', NR, I2-K+1, V, DCONJG( TAU ), - $ H( K, K ), LDH, WORK ) -* -* Apply G from the right to transform the columns of the -* matrix in rows I1 to min(K+NR,I). -* - CALL ZLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU, - $ H( I1, K ), LDH, WORK ) -* - IF( WANTZ ) THEN -* -* Accumulate transformations in the matrix Z -* - CALL ZLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ, - $ WORK ) - END IF - 150 CONTINUE -* -* Ensure that H(I,I-1) is real. +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== * - TEMP = H( I, I-1 ) - IF( DIMAG( TEMP ).NE.RZERO ) THEN - RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) ) - H( I, I-1 ) = RTEMP - TEMP = TEMP / RTEMP - IF( I2.GT.I ) - $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) - CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) - IF( WANTZ ) THEN - CALL ZSCAL( NH, TEMP, Z( ILO, I ), 1 ) - END IF - END IF -* - 160 CONTINUE -* -* Failure to converge in remaining number of iterations -* - INFO = I - RETURN + WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), + $ DBLE( WORK( 1 ) ) ), RZERO ) + END IF * - 170 CONTINUE -* -* A submatrix of order <= MAXB in rows and columns L to I has split -* off. Use the double-shift QR algorithm to handle it. -* - CALL ZLAHQR( WANTT, WANTZ, N, L, I, H, LDH, W, ILO, IHI, Z, LDZ, - $ INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Decrement number of remaining iterations, and return to start of -* the main loop with a new value of I. -* - ITN = ITN - ITS - I = L - 1 - GO TO 60 -* - 180 CONTINUE - WORK( 1 ) = MAX( 1, N ) - RETURN -* -* End of ZHSEQR +* ==== End of ZHSEQR ==== * END
--- a/libcruft/lapack/zlabrd.f +++ b/libcruft/lapack/zlabrd.f @@ -1,10 +1,9 @@ SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB @@ -88,7 +87,7 @@ * The n-by-nb matrix Y required to update the unreduced part * of A. * -* LDY (output) INTEGER +* LDY (input) INTEGER * The leading dimension of the array Y. LDY >= max(1,N). * * Further Details
--- a/libcruft/lapack/zlacgv.f +++ b/libcruft/lapack/zlacgv.f @@ -1,9 +1,8 @@ SUBROUTINE ZLACGV( N, X, INCX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlacn2.f @@ -0,0 +1,221 @@ + SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST +* .. +* .. Array Arguments .. + INTEGER ISAVE( 3 ) + COMPLEX*16 V( * ), X( * ) +* .. +* +* Purpose +* ======= +* +* ZLACN2 estimates the 1-norm of a square, complex matrix A. +* Reverse communication is used for evaluating matrix-vector products. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix. N >= 1. +* +* V (workspace) COMPLEX*16 array, dimension (N) +* On the final return, V = A*W, where EST = norm(V)/norm(W) +* (W is not returned). +* +* X (input/output) COMPLEX*16 array, dimension (N) +* On an intermediate return, X should be overwritten by +* A * X, if KASE=1, +* A' * X, if KASE=2, +* where A' is the conjugate transpose of A, and ZLACN2 must be +* re-called with all the other parameters unchanged. +* +* EST (input/output) DOUBLE PRECISION +* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be +* unchanged from the previous call to ZLACN2. +* On exit, EST is an estimate (a lower bound) for norm(A). +* +* KASE (input/output) INTEGER +* On the initial call to ZLACN2, KASE should be 0. +* On an intermediate return, KASE will be 1 or 2, indicating +* whether X should be overwritten by A * X or A' * X. +* On the final return from ZLACN2, KASE will again be 0. +* +* ISAVE (input/output) INTEGER array, dimension (3) +* ISAVE is used to save variables between calls to ZLACN2 +* +* Further Details +* ======= ======= +* +* Contributed by Nick Higham, University of Manchester. +* Originally named CONEST, dated March 16, 1988. +* +* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of +* a real or complex matrix, with applications to condition estimation", +* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. +* +* Last modified: April, 1999 +* +* This is a thread safe version of ZLACON, which uses the array ISAVE +* in place of a SAVE statement, as follows: +* +* ZLACON ZLACN2 +* JUMP ISAVE(1) +* J ISAVE(2) +* ITER ISAVE(3) +* +* ===================================================================== +* +* .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, JLAST + DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP +* .. +* .. External Functions .. + INTEGER IZMAX1 + DOUBLE PRECISION DLAMCH, DZSUM1 + EXTERNAL IZMAX1, DLAMCH, DZSUM1 +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG +* .. +* .. Executable Statements .. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = DCMPLX( ONE / DBLE( N ) ) + 10 CONTINUE + KASE = 1 + ISAVE( 1 ) = 1 + RETURN + END IF +* + GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) +* +* ................ ENTRY (ISAVE( 1 ) = 1) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. +* + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) +* ... QUIT + GO TO 130 + END IF + EST = DZSUM1( N, X, 1 ) +* + DO 30 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 30 CONTINUE + KASE = 2 + ISAVE( 1 ) = 2 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 2) +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. +* + 40 CONTINUE + ISAVE( 2 ) = IZMAX1( N, X, 1 ) + ISAVE( 3 ) = 2 +* +* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. +* + 50 CONTINUE + DO 60 I = 1, N + X( I ) = CZERO + 60 CONTINUE + X( ISAVE( 2 ) ) = CONE + KASE = 1 + ISAVE( 1 ) = 3 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 3) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 70 CONTINUE + CALL ZCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DZSUM1( N, V, 1 ) +* +* TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 100 +* + DO 80 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 80 CONTINUE + KASE = 2 + ISAVE( 1 ) = 4 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 4) +* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. +* + 90 CONTINUE + JLAST = ISAVE( 2 ) + ISAVE( 2 ) = IZMAX1( N, X, 1 ) + IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. + $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN + ISAVE( 3 ) = ISAVE( 3 ) + 1 + GO TO 50 + END IF +* +* ITERATION COMPLETE. FINAL STAGE. +* + 100 CONTINUE + ALTSGN = ONE + DO 110 I = 1, N + X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) + ALTSGN = -ALTSGN + 110 CONTINUE + KASE = 1 + ISAVE( 1 ) = 5 + RETURN +* +* ................ ENTRY (ISAVE( 1 ) = 5) +* X HAS BEEN OVERWRITTEN BY A*X. +* + 120 CONTINUE + TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL ZCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF +* + 130 CONTINUE + KASE = 0 + RETURN +* +* End of ZLACN2 +* + END
--- a/libcruft/lapack/zlacon.f +++ b/libcruft/lapack/zlacon.f @@ -1,9 +1,8 @@ SUBROUTINE ZLACON( N, V, X, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER KASE, N @@ -36,8 +35,10 @@ * where A' is the conjugate transpose of A, and ZLACON must be * re-called with all the other parameters unchanged. * -* EST (output) DOUBLE PRECISION -* An estimate (a lower bound) for norm(A). +* EST (input/output) DOUBLE PRECISION +* On entry with KASE = 1 or 2 and JUMP = 3, EST should be +* unchanged from the previous call to ZLACON. +* On exit, EST is an estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to ZLACON, KASE should be 0. @@ -126,7 +127,7 @@ RETURN * * ................ ENTRY (JUMP = 2) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. +* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE J = IZMAX1( N, X, 1 ) @@ -169,7 +170,7 @@ RETURN * * ................ ENTRY (JUMP = 4) -* X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. +* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = J
--- a/libcruft/lapack/zlacpy.f +++ b/libcruft/lapack/zlacpy.f @@ -1,9 +1,8 @@ SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zladiv.f +++ b/libcruft/lapack/zladiv.f @@ -1,9 +1,8 @@ - DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) + COMPLEX*16 FUNCTION ZLADIV( X, Y ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. COMPLEX*16 X, Y
--- a/libcruft/lapack/zlahqr.f +++ b/libcruft/lapack/zlahqr.f @@ -1,42 +1,42 @@ SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. * -* Purpose -* ======= +* Purpose +* ======= * -* ZLAHQR is an auxiliary routine called by ZHSEQR to update the -* eigenvalues and Schur decomposition already computed by ZHSEQR, by -* dealing with the Hessenberg submatrix in rows and columns ILO to IHI. +* ZLAHQR is an auxiliary routine called by CHSEQR to update the +* eigenvalues and Schur decomposition already computed by CHSEQR, by +* dealing with the Hessenberg submatrix in rows and columns ILO to +* IHI. * -* Arguments -* ========= +* Arguments +* ========= * -* WANTT (input) LOGICAL +* WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * -* WANTZ (input) LOGICAL +* WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * -* N (input) INTEGER +* N (input) INTEGER * The order of the matrix H. N >= 0. * -* ILO (input) INTEGER -* IHI (input) INTEGER +* ILO (input) INTEGER +* IHI (input) INTEGER * It is assumed that H is already upper triangular in rows and * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). * ZLAHQR works primarily with the Hessenberg submatrix in rows @@ -44,80 +44,115 @@ * H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * -* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. -* On exit, if WANTT is .TRUE., H is upper triangular in rows -* and columns ILO:IHI, with any 2-by-2 diagonal blocks in -* standard form. If WANTT is .FALSE., the contents of H are -* unspecified on exit. +* On exit, if INFO is zero and if WANTT is .TRUE., then H +* is upper triangular in rows and columns ILO:IHI. If INFO +* is zero and if WANTT is .FALSE., then the contents of H +* are unspecified on exit. The output state of H in case +* INF is positive is below under the description of INFO. * -* LDH (input) INTEGER +* LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * -* W (output) COMPLEX*16 array, dimension (N) +* W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues ILO to IHI are stored in the * corresponding elements of W. If WANTT is .TRUE., 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). * -* ILOZ (input) INTEGER -* IHIZ (input) INTEGER +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * -* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) +* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current -* matrix Z of transformations accumulated by ZHSEQR, and on +* matrix Z of transformations accumulated by CHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * -* LDZ (input) INTEGER +* LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * -* INFO (output) INTEGER -* = 0: successful exit -* > 0: if INFO = i, ZLAHQR failed to compute all the -* eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1) -* iterations; elements i+1:ihi of W contain those -* eigenvalues which have been successfully computed. +* INFO (output) INTEGER +* = 0: successful exit +* .GT. 0: if INFO = i, ZLAHQR failed to compute all the +* eigenvalues ILO to IHI in a total of 30 iterations +* per eigenvalue; elements i+1:ihi of W contain +* those eigenvalues which have been successfully +* computed. +* +* If INFO .GT. 0 and WANTT is .FALSE., then on exit, +* the remaining unconverged eigenvalues are the +* eigenvalues of the upper Hessenberg matrix +* rows and columns ILO thorugh INFO of the final, +* output value of H. +* +* If INFO .GT. 0 and WANTT is .TRUE., then on exit +* (*) (initial value of H)*U = U*(final value of H) +* where U is an orthognal matrix. The final +* value of H is upper Hessenberg and triangular in +* rows and columns INFO+1 through IHI. * -* ===================================================================== +* If INFO .GT. 0 and WANTZ is .TRUE., then on exit +* (final value of Z) = (initial value of Z)*U +* where U is the orthogonal matrix in (*) +* (regardless of the value of WANTT.) +* +* Further Details +* =============== +* +* 02-96 Based on modifications by +* David Day, Sandia National Laboratory, USA +* +* 12-04 Further modifications by +* Ralph Byers, University of Kansas, USA +* +* This is a modified version of ZLAHQR from LAPACK version 3.0. +* It is (1) more robust against overflow and underflow and +* (2) adopts the more conservative Ahues & Tisseur stopping +* criterion (LAWN 122, 1997). +* +* ========================================================= * * .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 30 ) COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION RZERO, HALF - PARAMETER ( RZERO = 0.0D+0, HALF = 0.5D+0 ) + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE, HALF + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) DOUBLE PRECISION DAT1 - PARAMETER ( DAT1 = 0.75D+0 ) + PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) * .. * .. Local Scalars .. - INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ - DOUBLE PRECISION H10, H21, RTEMP, S, SMLNUM, T2, TST1, ULP - COMPLEX*16 CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2, - $ X, Y + COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, + $ V2, X, Y + DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, + $ SAFMIN, SMLNUM, SX, T2, TST, ULP + INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ * .. * .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) COMPLEX*16 V( 2 ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, ZLANHS COMPLEX*16 ZLADIV - EXTERNAL DLAMCH, ZLANHS, ZLADIV + DOUBLE PRECISION DLAMCH + EXTERNAL ZLADIV, DLAMCH * .. * .. External Subroutines .. - EXTERNAL ZCOPY, ZLARFG, ZSCAL + EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT * .. -* .. Statement Functions .. - DOUBLE PRECISION CABS1 -* .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. @@ -134,14 +169,47 @@ RETURN END IF * +* ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO +* ==== ensure that subdiagonal entries are real ==== + DO 20 I = ILO + 1, IHI + IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN +* ==== The following redundant normalization +* . avoids problems with both gradual and +* . sudden underflow in ABS(H(I,I-1)) ==== + SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) + SC = DCONJG( SC ) / ABS( SC ) + H( I, I-1 ) = ABS( H( I, I-1 ) ) + IF( WANTT ) THEN + JLO = 1 + JHI = N + ELSE + JLO = ILO + JHI = IHI + END IF + CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) + CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), + $ H( JLO, I ), 1 ) + IF( WANTZ ) + $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) + END IF + 20 CONTINUE +* NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. -* If norm(H) <= sqrt(OVFL), overflow should not occur. * - ULP = DLAMCH( 'Precision' ) - SMLNUM = DLAMCH( 'Safe minimum' ) / ULP + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are @@ -152,10 +220,6 @@ I2 = N END IF * -* ITN is the total number of QR iterations allowed. -* - ITN = 30*NH -* * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1. Each iteration of the loop works * with the active submatrix in rows and columns L to I. @@ -163,27 +227,46 @@ * H(L,L-1) is negligible so that the matrix splits. * I = IHI - 10 CONTINUE + 30 CONTINUE IF( I.LT.ILO ) - $ GO TO 130 + $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO - DO 110 ITS = 0, ITN + DO 130 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * - DO 20 K = I, L + 1, -1 - TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) - IF( TST1.EQ.RZERO ) - $ TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK ) - IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) ) - $ GO TO 30 - 20 CONTINUE - 30 CONTINUE + DO 40 K = I, L + 1, -1 + IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) + $ GO TO 50 + TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) + IF( TST.EQ.ZERO ) THEN + IF( K-2.GE.ILO ) + $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) + IF( K+1.LE.IHI ) + $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) + END IF +* ==== The following is a conservative small subdiagonal +* . deflation criterion due to Ahues & Tisseur (LAWN 122, +* . 1997). It has better mathematical foundation and +* . improves accuracy in some examples. ==== + IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN + AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + AA = MAX( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + BB = MIN( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + S = AA + AB + IF( BA*( AB / S ).LE.MAX( SMLNUM, + $ ULP*( BB*( AA / S ) ) ) )GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE L = K IF( L.GT.ILO ) THEN * @@ -195,7 +278,7 @@ * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) - $ GO TO 120 + $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix @@ -217,19 +300,24 @@ * Wilkinson's shift. * T = H( I, I ) - U = H( I-1, I )*DBLE( H( I, I-1 ) ) - IF( U.NE.ZERO ) THEN + U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) + S = CABS1( U ) + IF( S.NE.RZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) - Y = SQRT( X*X+U ) - IF( DBLE( X )*DBLE( Y )+DIMAG( X )*DIMAG( Y ).LT.RZERO ) - $ Y = -Y - T = T - ZLADIV( U, ( X+Y ) ) + SX = CABS1( X ) + S = MAX( S, CABS1( X ) ) + Y = S*SQRT( ( X / S )**2+( U / S )**2 ) + IF( SX.GT.RZERO ) THEN + IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* + $ DIMAG( Y ).LT.RZERO )Y = -Y + END IF + T = T - U*ZLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * - DO 40 M = I - 1, L + 1, -1 + DO 60 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) @@ -245,10 +333,10 @@ V( 1 ) = H11S V( 2 ) = H21 H10 = H( M, M-1 ) - TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) - IF( ABS( H10*H21 ).LE.ULP*TST1 ) - $ GO TO 50 - 40 CONTINUE + IF( ABS( H10 )*ABS( H21 ).LE.ULP* + $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) + $ GO TO 70 + 60 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T @@ -258,11 +346,11 @@ H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 - 50 CONTINUE + 70 CONTINUE * * Single-shift QR step * - DO 100 K = M, I - 1 + DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, @@ -289,30 +377,30 @@ * Apply G from the left to transform the rows of the matrix * in columns K to I2. * - DO 60 J = K, I2 + DO 80 J = K, I2 SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 - 60 CONTINUE + 80 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * - DO 70 J = I1, MIN( K+2, I ) + DO 90 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) - 70 CONTINUE + 90 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * - DO 80 J = ILOZ, IHIZ + DO 100 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) - 80 CONTINUE + 100 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN @@ -327,7 +415,7 @@ H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP - DO 90 J = M, I + DO 110 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) @@ -337,9 +425,9 @@ $ 1 ) END IF END IF - 90 CONTINUE + 110 CONTINUE END IF - 100 CONTINUE + 120 CONTINUE * * Ensure that H(I,I-1) is real. * @@ -356,27 +444,25 @@ END IF END IF * - 110 CONTINUE + 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * - 120 CONTINUE + 140 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * -* Decrement number of remaining iterations, and return to start of -* the main loop with new value of I. +* return to start of the main loop with new value of I. * - ITN = ITN - ITS I = L - 1 - GO TO 10 + GO TO 30 * - 130 CONTINUE + 150 CONTINUE RETURN * * End of ZLAHQR
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlahr2.f @@ -0,0 +1,240 @@ + SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* Purpose +* ======= +* +* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) +* matrix A so that elements below the k-th subdiagonal are zero. The +* reduction is performed by an unitary similarity transformation +* Q' * A * Q. The routine returns the matrices V and T which determine +* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. +* +* This is an auxiliary routine called by ZGEHRD. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. +* +* K (input) INTEGER +* The offset for the reduction. Elements below the k-th +* subdiagonal in the first NB columns are reduced to zero. +* K < N. +* +* NB (input) INTEGER +* The number of columns to be reduced. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) +* On entry, the n-by-(n-k+1) general matrix A. +* On exit, the elements on and above the k-th subdiagonal in +* the first NB columns are overwritten with the corresponding +* elements of the reduced matrix; the elements below the k-th +* subdiagonal, with the array TAU, represent the matrix Q as a +* product of elementary reflectors. The other columns of A are +* unchanged. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (output) COMPLEX*16 array, dimension (NB) +* The scalar factors of the elementary reflectors. See Further +* Details. +* +* T (output) COMPLEX*16 array, dimension (LDT,NB) +* The upper triangular matrix T. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= NB. +* +* Y (output) COMPLEX*16 array, dimension (LDY,NB) +* The n-by-nb matrix Y. +* +* LDY (input) INTEGER +* The leading dimension of the array Y. LDY >= N. +* +* Further Details +* =============== +* +* The matrix Q is represented as a product of nb elementary reflectors +* +* Q = H(1) H(2) . . . H(nb). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a complex scalar, and v is a complex vector with +* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in +* A(i+k+1:n,i), and tau in TAU(i). +* +* The elements of the vectors v together form the (n-k+1)-by-nb matrix +* V which is needed, with T and Y, to apply the transformation to the +* unreduced part of the matrix, using an update of the form: +* A := (I - V*T*V') * (A - Y*V'). +* +* The contents of A on exit are illustrated by the following example +* with n = 7, k = 3 and nb = 2: +* +* ( a a a a a ) +* ( a a a a a ) +* ( a a a a a ) +* ( h h a a a ) +* ( v1 h a a a ) +* ( v1 v2 a a a ) +* ( v1 v2 a a a ) +* +* where a denotes an element of the original matrix A, h denotes a +* modified element of the upper Hessenberg matrix H, and vi denotes an +* element of the vector defining H(i). +* +* This file is a slight modification of LAPACK-3.0's ZLAHRD +* incorporating improvements proposed by Quintana-Orti and Van de +* Gejin. Note that the entries of A(1:K,2:NB) differ from those +* returned by the original LAPACK routine. This function is +* not backward compatible with LAPACK3.0. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 EI +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, + $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V' +* + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) +* +* Apply I - V * T' * V' to this column (call it b) from the +* left, using the last column of T as workspace +* +* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) +* ( V2 ) ( b2 ) +* +* where V1 is unit lower triangular +* +* w := V1' * b1 +* + CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2'*b2 +* + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) +* +* w := T'*w +* + CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL ZTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(I) to annihilate +* A(K+I+1:N,I) +* + CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(K+1:N,I) +* + CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) +* +* Compute T(1:I,I) +* + CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* +* Compute Y(1:K,1:NB) +* + CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) +* + RETURN +* +* End of ZLAHR2 +* + END
--- a/libcruft/lapack/zlahrd.f +++ b/libcruft/lapack/zlahrd.f @@ -1,9 +1,8 @@ SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -22,7 +21,9 @@ * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * -* This is an auxiliary routine called by ZGEHRD. +* This is an OBSOLETE auxiliary routine. +* This routine will be 'deprecated' in a future release. +* Please use the new routine ZLAHR2 instead. * * Arguments * =========
--- a/libcruft/lapack/zlange.f +++ b/libcruft/lapack/zlange.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER NORM @@ -37,7 +36,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -60,7 +59,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. *
--- a/libcruft/lapack/zlanhe.f +++ b/libcruft/lapack/zlanhe.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER NORM, UPLO @@ -37,7 +36,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -69,7 +68,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. *
--- a/libcruft/lapack/zlanhs.f +++ b/libcruft/lapack/zlanhs.f @@ -1,9 +1,8 @@ DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER NORM @@ -37,7 +36,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -57,7 +56,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. *
--- a/libcruft/lapack/zlantr.f +++ b/libcruft/lapack/zlantr.f @@ -1,10 +1,9 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO @@ -38,7 +37,7 @@ * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= @@ -80,7 +79,7 @@ * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. *
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlaqr0.f @@ -0,0 +1,601 @@ + SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* ZLAQR0 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 +* ========= +* +* WANTT (input) LOGICAL +* = .TRUE. : the full Schur form T is required; +* = .FALSE.: only eigenvalues are required. +* +* WANTZ (input) LOGICAL +* = .TRUE. : the matrix of Schur vectors Z is required; +* = .FALSE.: Schur vectors are not required. +* +* 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 and, if ILO.GT.1, +* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +* previous call to ZGEBAL, and then passed to ZGEHRD when the +* matrix output by ZGEBAL 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*16 array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and WANTT is .TRUE., then H +* contains the upper triangular matrix T from the Schur +* decomposition (the Schur form). If INFO = 0 and WANT is +* .FALSE., then 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.) +* +* This subroutine may explicitly set 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*16 array, dimension (N) +* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored +* in W(ILO:IHI). If WANTT is .TRUE., then 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*16 array, dimension (LDZ,IHI) +* If WANTZ is .FALSE., then Z is not referenced. +* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +* (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 WANTZ is .TRUE. +* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +* +* WORK (workspace/output) COMPLEX*16 array, dimension LWORK +* On exit, if LWORK = -1, 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 ZLAQR0 does a workspace query. +* In this case, ZLAQR0 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 +* .GT. 0: if INFO = i, ZLAQR0 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 WANT is .FALSE., 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 WANTT is .TRUE., 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 WANTZ is .TRUE., then on exit +* +* (final value of Z(ILO:IHI,ILOZ:IHIZ) +* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +* +* where U is the unitary matrix in (*) (regard- +* less of the value of WANTT.) +* +* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +* accessed. +* +* ================================================================ +* 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 +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by increasing the size of the +* . deflation window after KEXNW iterations. ===== +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR3 ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR3 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR3 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or +* . ZLAHQR on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL ZLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, WORK, LWORK, INF ) + ELSE + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, INF ) + END IF + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR0 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlaqr1.f @@ -0,0 +1,97 @@ + SUBROUTINE ZLAQR1( 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*16 S1, S2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), V( * ) +* .. +* +* Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 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*16 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*16 +* S2 S1 and S2 are the shifts defining K in (*) above. +* +* V (output) COMPLEX*16 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*16 ZERO + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM + DOUBLE PRECISION H21S, H31S, S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( 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
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlaqr2.f @@ -0,0 +1,437 @@ + SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* This subroutine is identical to ZLAQR3 except that it avoids +* recursion by calling ZLAHQR instead of ZLAQR4. +* +* +* ****************************************************************** +* Aggressive early deflation: +* +* This subroutine accepts as input an upper Hessenberg matrix +* H and performs an unitary similarity transformation +* designed to detect and deflate fully converged eigenvalues from +* a trailing principal submatrix. On output H has been over- +* written by a new Hessenberg matrix that is a perturbation of +* an unitary similarity transformation of H. It is to be +* hoped that the final version of H has many zero subdiagonal +* entries. +* +* ****************************************************************** +* WANTT (input) LOGICAL +* If .TRUE., then the Hessenberg matrix H is fully updated +* so that the triangular Schur factor may be +* computed (in cooperation with the calling subroutine). +* If .FALSE., then only enough of H is updated to preserve +* the eigenvalues. +* +* WANTZ (input) LOGICAL +* If .TRUE., then the unitary matrix Z is updated so +* so that the unitary Schur factor may be computed +* (in cooperation with the calling subroutine). +* If .FALSE., then Z is not referenced. +* +* N (input) INTEGER +* The order of the matrix H and (if WANTZ is .TRUE.) the +* order of the unitary matrix Z. +* +* KTOP (input) INTEGER +* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +* KBOT and KTOP together determine an isolated block +* along the diagonal of the Hessenberg matrix. +* +* KBOT (input) INTEGER +* It is assumed without a check that either +* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +* determine an isolated block along the diagonal of the +* Hessenberg matrix. +* +* NW (input) INTEGER +* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On input the initial N-by-N section of H stores the +* Hessenberg matrix undergoing aggressive early deflation. +* On output H has been transformed by a unitary +* similarity transformation, perturbed, and the returned +* to Hessenberg form that (it is to be hoped) has some +* zero subdiagonal entries. +* +* LDH (input) integer +* Leading dimension of H just as declared in the calling +* subroutine. N .LE. LDH +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) +* IF WANTZ is .TRUE., then on output, the unitary +* similarity transformation mentioned above has been +* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ is .FALSE., then Z is unreferenced. +* +* LDZ (input) integer +* The leading dimension of Z just as declared in the +* calling subroutine. 1 .LE. LDZ. +* +* NS (output) integer +* The number of unconverged (ie approximate) eigenvalues +* returned in SR and SI that may be used as shifts by the +* calling subroutine. +* +* ND (output) integer +* The number of converged eigenvalues uncovered by this +* subroutine. +* +* SH (output) COMPLEX*16 array, dimension KBOT +* On output, approximate eigenvalues that may +* be used for shifts are stored in SH(KBOT-ND-NS+1) +* through SR(KBOT-ND). Converged eigenvalues are +* stored in SH(KBOT-ND+1) through SH(KBOT). +* +* V (workspace) COMPLEX*16 array, dimension (LDV,NW) +* An NW-by-NW work array. +* +* LDV (input) integer scalar +* The leading dimension of V just as declared in the +* calling subroutine. NW .LE. LDV +* +* NH (input) integer scalar +* The number of columns of T. NH.GE.NW. +* +* T (workspace) COMPLEX*16 array, dimension (LDT,NW) +* +* LDT (input) integer +* The leading dimension of T just as declared in the +* calling subroutine. NW .LE. LDT +* +* NV (input) integer +* The number of rows of work array WV available for +* workspace. NV.GE.NW. +* +* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) +* +* LDWV (input) integer +* The leading dimension of W just as declared in the +* calling subroutine. NW .LE. LDV +* +* WORK (workspace) COMPLEX*16 array, dimension LWORK. +* On exit, WORK(1) is set to an estimate of the optimal value +* of LWORK for the given values of N, NW, KTOP and KBOT. +* +* LWORK (input) integer +* The dimension of the work array WORK. LWORK = 2*NW +* suffices, but greater efficiency may result from larger +* values of LWORK. +* +* If LWORK = -1, then a workspace query is assumed; ZLAQR2 +* only estimates the optimal workspace size for the given +* values of N, NW, KTOP and KBOT. The estimate is returned +* in WORK(1). No error message related to LWORK is issued +* by XERBLA. Neither H nor Z are accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================== +* .. Parameters .. + 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 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNGHR ==== +* + CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of ZUNGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR2 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlaqr3.f @@ -0,0 +1,448 @@ + SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ****************************************************************** +* Aggressive early deflation: +* +* This subroutine accepts as input an upper Hessenberg matrix +* H and performs an unitary similarity transformation +* designed to detect and deflate fully converged eigenvalues from +* a trailing principal submatrix. On output H has been over- +* written by a new Hessenberg matrix that is a perturbation of +* an unitary similarity transformation of H. It is to be +* hoped that the final version of H has many zero subdiagonal +* entries. +* +* ****************************************************************** +* WANTT (input) LOGICAL +* If .TRUE., then the Hessenberg matrix H is fully updated +* so that the triangular Schur factor may be +* computed (in cooperation with the calling subroutine). +* If .FALSE., then only enough of H is updated to preserve +* the eigenvalues. +* +* WANTZ (input) LOGICAL +* If .TRUE., then the unitary matrix Z is updated so +* so that the unitary Schur factor may be computed +* (in cooperation with the calling subroutine). +* If .FALSE., then Z is not referenced. +* +* N (input) INTEGER +* The order of the matrix H and (if WANTZ is .TRUE.) the +* order of the unitary matrix Z. +* +* KTOP (input) INTEGER +* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +* KBOT and KTOP together determine an isolated block +* along the diagonal of the Hessenberg matrix. +* +* KBOT (input) INTEGER +* It is assumed without a check that either +* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +* determine an isolated block along the diagonal of the +* Hessenberg matrix. +* +* NW (input) INTEGER +* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +* +* H (input/output) COMPLEX*16 array, dimension (LDH,N) +* On input the initial N-by-N section of H stores the +* Hessenberg matrix undergoing aggressive early deflation. +* On output H has been transformed by a unitary +* similarity transformation, perturbed, and the returned +* to Hessenberg form that (it is to be hoped) has some +* zero subdiagonal entries. +* +* LDH (input) integer +* Leading dimension of H just as declared in the calling +* subroutine. N .LE. LDH +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +* +* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) +* IF WANTZ is .TRUE., then on output, the unitary +* similarity transformation mentioned above has been +* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ is .FALSE., then Z is unreferenced. +* +* LDZ (input) integer +* The leading dimension of Z just as declared in the +* calling subroutine. 1 .LE. LDZ. +* +* NS (output) integer +* The number of unconverged (ie approximate) eigenvalues +* returned in SR and SI that may be used as shifts by the +* calling subroutine. +* +* ND (output) integer +* The number of converged eigenvalues uncovered by this +* subroutine. +* +* SH (output) COMPLEX*16 array, dimension KBOT +* On output, approximate eigenvalues that may +* be used for shifts are stored in SH(KBOT-ND-NS+1) +* through SR(KBOT-ND). Converged eigenvalues are +* stored in SH(KBOT-ND+1) through SH(KBOT). +* +* V (workspace) COMPLEX*16 array, dimension (LDV,NW) +* An NW-by-NW work array. +* +* LDV (input) integer scalar +* The leading dimension of V just as declared in the +* calling subroutine. NW .LE. LDV +* +* NH (input) integer scalar +* The number of columns of T. NH.GE.NW. +* +* T (workspace) COMPLEX*16 array, dimension (LDT,NW) +* +* LDT (input) integer +* The leading dimension of T just as declared in the +* calling subroutine. NW .LE. LDT +* +* NV (input) integer +* The number of rows of work array WV available for +* workspace. NV.GE.NW. +* +* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) +* +* LDWV (input) integer +* The leading dimension of W just as declared in the +* calling subroutine. NW .LE. LDV +* +* WORK (workspace) COMPLEX*16 array, dimension LWORK. +* On exit, WORK(1) is set to an estimate of the optimal value +* of LWORK for the given values of N, NW, KTOP and KBOT. +* +* LWORK (input) integer +* The dimension of the work array WORK. LWORK = 2*NW +* suffices, but greater efficiency may result from larger +* values of LWORK. +* +* If LWORK = -1, then a workspace query is assumed; ZLAQR3 +* only estimates the optimal workspace size for the given +* values of N, NW, KTOP and KBOT. The estimate is returned +* in WORK(1). No error message related to LWORK is issued +* by XERBLA. Neither H nor Z are accessed. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ================================================================== +* .. Parameters .. + 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 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNGHR ==== +* + CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZLAQR4 ==== +* + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, + $ LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) + END IF +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. (A modified version +* . of ZUNGHR that accumulates block Householder +* . transformations into V directly might be +* . marginally more efficient than the following.) ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR3 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlaqr4.f @@ -0,0 +1,602 @@ + SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* This subroutine implements one level of recursion for ZLAQR0. +* It is a complete implementation of the small bulge multi-shift +* QR algorithm. It may be called by ZLAQR0 and, for large enough +* deflation window size, it may be called by ZLAQR3. This +* subroutine is identical to ZLAQR0 except that it calls ZLAQR2 +* instead of ZLAQR3. +* +* Purpose +* ======= +* +* ZLAQR4 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 +* ========= +* +* WANTT (input) LOGICAL +* = .TRUE. : the full Schur form T is required; +* = .FALSE.: only eigenvalues are required. +* +* WANTZ (input) LOGICAL +* = .TRUE. : the matrix of Schur vectors Z is required; +* = .FALSE.: Schur vectors are not required. +* +* 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 and, if ILO.GT.1, +* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +* previous call to ZGEBAL, and then passed to ZGEHRD when the +* matrix output by ZGEBAL 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*16 array, dimension (LDH,N) +* On entry, the upper Hessenberg matrix H. +* On exit, if INFO = 0 and WANTT is .TRUE., then H +* contains the upper triangular matrix T from the Schur +* decomposition (the Schur form). If INFO = 0 and WANT is +* .FALSE., then 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.) +* +* This subroutine may explicitly set 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*16 array, dimension (N) +* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored +* in W(ILO:IHI). If WANTT is .TRUE., then 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*16 array, dimension (LDZ,IHI) +* If WANTZ is .FALSE., then Z is not referenced. +* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +* (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 WANTZ is .TRUE. +* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +* +* WORK (workspace/output) COMPLEX*16 array, dimension LWORK +* On exit, if LWORK = -1, 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 ZLAQR4 does a workspace query. +* In this case, ZLAQR4 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 +* .GT. 0: if INFO = i, ZLAQR4 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 WANT is .FALSE., 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 WANTT is .TRUE., 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 WANTZ is .TRUE., then on exit +* +* (final value of Z(ILO:IHI,ILOZ:IHIZ) +* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +* +* where U is the unitary matrix in (*) (regard- +* less of the value of WANTT.) +* +* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +* accessed. +* +* ================================================================ +* 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 +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by increasing the size of the +* . deflation window after KEXNW iterations. ===== +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== +* + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + IF( N.LE.NTINY ) THEN +* +* ==== Estimate optimal workspace. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR2 ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size ==== +* + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN +* +* ==== Typical deflation window. If possible and +* . advisable, nibble the entire active block. +* . If not, use size NWR or NWR+1 depending upon +* . which has the smaller corresponding subdiagonal +* . entry (a heuristic). ==== +* + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE +* +* ==== Exceptional deflation window. If there have +* . been no deflations in KEXNW or more iterations, +* . then vary the deflation window size. At first, +* . because, larger windows are, in general, more +* . powerful than smaller ones, rapidly increase the +* . window up to the maximum reasonable and possible. +* . Then maybe try a slightly smaller window. ==== +* + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR2 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR2 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAHQR +* . on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, + $ 1, INF ) + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR4 ==== +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/zlaqr5.f @@ -0,0 +1,809 @@ + 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 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), + $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* This auxiliary subroutine called by ZLAQR0 performs a +* single small-bulge multi-shift QR sweep. +* +* WANTT (input) logical scalar +* WANTT = .true. if the triangular Schur factor +* is being computed. WANTT is set to .false. otherwise. +* +* WANTZ (input) logical scalar +* WANTZ = .true. if the unitary Schur factor is being +* computed. WANTZ is set to .false. otherwise. +* +* KACC22 (input) integer with value 0, 1, or 2. +* Specifies the computation mode of far-from-diagonal +* orthogonal updates. +* = 0: ZLAQR5 does not accumulate reflections and does not +* use matrix-matrix multiply to update far-from-diagonal +* matrix entries. +* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix +* multiply to update the far-from-diagonal matrix entries. +* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix +* multiply to update the far-from-diagonal matrix entries, +* and takes advantage of 2-by-2 block structure during +* matrix multiplies. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H upon which this +* subroutine operates. +* +* KTOP (input) integer scalar +* KBOT (input) integer scalar +* These are the first and last rows and columns of an +* isolated diagonal block upon which the QR sweep is to be +* applied. It is assumed without a check that +* either KTOP = 1 or H(KTOP,KTOP-1) = 0 +* and +* either KBOT = N or H(KBOT+1,KBOT) = 0. +* +* NSHFTS (input) integer scalar +* NSHFTS gives the number of simultaneous shifts. NSHFTS +* must be positive and even. +* +* S (input) COMPLEX*16 array of size (NSHFTS) +* S contains the shifts of origin that define the multi- +* shift QR sweep. +* +* H (input/output) COMPLEX*16 array of size (LDH,N) +* On input H contains a Hessenberg matrix. On output a +* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied +* to the isolated diagonal block in rows and columns KTOP +* through KBOT. +* +* LDH (input) integer scalar +* LDH is the leading dimension of H just as declared in the +* calling procedure. LDH.GE.MAX(1,N). +* +* ILOZ (input) INTEGER +* IHIZ (input) INTEGER +* Specify the rows of Z to which transformations must be +* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N +* +* Z (input/output) COMPLEX*16 array of size (LDZ,IHI) +* If WANTZ = .TRUE., then the QR Sweep unitary +* similarity transformation is accumulated into +* Z(ILOZ:IHIZ,ILO:IHI) from the right. +* If WANTZ = .FALSE., then Z is unreferenced. +* +* LDZ (input) integer scalar +* LDA is the leading dimension of Z just as declared in +* the calling procedure. LDZ.GE.N. +* +* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) +* +* LDV (input) integer scalar +* LDV is the leading dimension of V as declared in the +* calling procedure. LDV.GE.3. +* +* U (workspace) COMPLEX*16 array of size +* (LDU,3*NSHFTS-3) +* +* LDU (input) integer scalar +* LDU is the leading dimension of U just as declared in the +* in the calling subroutine. LDU.GE.3*NSHFTS-3. +* +* NH (input) integer scalar +* NH is the number of columns in array WH available for +* workspace. NH.GE.1. +* +* WH (workspace) COMPLEX*16 array of size (LDWH,NH) +* +* LDWH (input) integer scalar +* Leading dimension of WH just as declared in the +* calling procedure. LDWH.GE.3*NSHFTS-3. +* +* NV (input) integer scalar +* NV is the number of rows in WV agailable for workspace. +* NV.GE.1. +* +* WV (workspace) COMPLEX*16 array of size +* (LDWV,3*NSHFTS-3) +* +* LDWV (input) integer scalar +* LDWV is the leading dimension of WV as declared in the +* in the calling subroutine. LDWV.GE.NV. +* +* ================================================================ +* Based on contributions by +* Karen Braman and Ralph Byers, Department of Mathematics, +* University of Kansas, USA +* +* ============================================================ +* Reference: +* +* 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. +* +* ============================================================ +* .. Parameters .. + 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 ) +* .. +* .. Local Scalars .. + 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 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. +* + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD +* .. +* .. Local Arrays .. + COMPLEX*16 VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, + $ ZTRMM +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( NSHFTS.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( KTOP.GE.KBOT ) + $ RETURN +* +* ==== NSHFTS is supposed to be even, but if is odd, +* . then simply reduce it by one. ==== +* + NS = NSHFTS - MOD( NSHFTS, 2 ) +* +* ==== Machine constants for deflation ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + NBMPS = NS / 2 +* +* ==== KDU = width of slab ==== +* + KDU = 6*NBMPS - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + 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 ) +* +* ==== Near-the-diagonal bulge chase. The following loop +* . performs the near-the-diagonal part of a small bulge +* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal +* . chunk extends from column INCOL to column NDCOL +* . (including both column INCOL and column NDCOL). The +* . following loop chases a 3*NBMPS column long chain of +* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL +* . may be less than KTOP and and NDCOL may be greater than +* . KBOT indicating phantom columns from which to chase +* . bulges before they are actually introduced or to which +* . to chase bulges beyond column KBOT.) ==== +* + DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) +* +* ==== Bulges number MTOP to MBOT are active double implicit +* . shift bulges. There may or may not also be small +* . 2-by-2 bulge, if there is room. The inactive bulges +* . (if any) must wait until the active bulges have moved +* . down the diagonal to make room. The phantom matrix +* . paradigm described above helps keep track. ==== +* + 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 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + 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 ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. (The +* . initial bulge is always collapsed.) Use +* . the two-small-subdiagonals trick to try +* . to get it started again. If V(2,M).NE.0 and +* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then +* . this bulge is collapsing into a zero +* . subdiagonal. It will be restarted next +* . trip through the loop.) +* + IF( V( 1, M ).NE.ZERO .AND. + $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, + $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) + $ THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K). If the +* . fill resulting from the new reflector +* . is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), + $ S( 2*M ), VT ) + SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + + $ CABS1( VT( 3 ) ) + IF( SCL.NE.RZERO ) THEN + VT( 1 ) = VT( 1 ) / SCL + VT( 2 ) = VT( 2 ) / SCL + VT( 3 ) = VT( 3 ) / SCL + END IF +* +* ==== The following is the traditional and +* . conservative two-small-subdiagonals +* . test. ==== +* . + IF( CABS1( H( K+1, K ) )* + $ ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* + $ CABS1( VT( 1 ) )*( CABS1( H( K, + $ K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, + $ K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. If +* . the old reflector is diagonal (only +* . possible with underflows), then +* . change it to I. Otherwise, use +* . it with trepidation. ==== +* + IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) + $ THEN + V( 1, M ) = ZERO + ELSE + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + END IF + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + ALPHA = VT( 1 ) + CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = H( K+1, K ) + + $ H( K+2, K )*DCONJG( VT( 2 ) ) + + $ H( K+3, K )*DCONJG( VT( 3 ) ) + H( K+1, K ) = H( K+1, K ) - + $ DCONJG( VT( 1 ) )*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 +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + 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 + ELSE +* +* ==== Initialize V(1,M22) here to avoid possible undefined +* . variable problems later. ==== +* + V( 1, M22 ) = ZERO + END IF +* +* ==== Multiply H by reflections from the left ==== +* + 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 +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + 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 +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + 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 +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + 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 +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + 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 +* +* ==== Vigilant deflation check ==== +* + 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 ) ) +* +* ==== The following convergence test requires that +* . the tradition small-compared-to-nearby-diagonals +* . criterion and the Ahues & Tisseur (LAWN 122, 1997) +* . criteria both be satisfied. The latter improves +* . accuracy in some examples. Falling back on an +* . alternate convergence criterion when TST1 or TST2 +* . is zero (as done here) is traditional but probably +* . unnecessary. ==== +* + 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 +* +* ==== Fill in the last row of each bulge. ==== +* + 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 +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 140 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + 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 +* +* ==== Updates not exploiting the 2-by-2 block +* . structure of U. K1 and NU keep track of +* . the location and size of U in the special +* . cases of introducing bulges and chasing +* . bulges off the bottom. In these special +* . cases and in case the number of shifts +* . is NS = 2, there is no 2-by-2 block +* . structure to exploit. ==== +* + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 +* +* ==== Horizontal Multiply ==== +* + 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 +* +* ==== Vertical multiply ==== +* + 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 +* +* ==== Z multiply (also vertical) ==== +* + 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 +* +* ==== Updates exploiting U's 2-by-2 block structure. +* . (I2, I4, J2, J4 are the last rows and columns +* . of the blocks.) ==== +* + I2 = ( KDU+1 ) / 2 + I4 = KDU + J2 = I4 - I2 + J4 = KDU +* +* ==== KZS and KNZ deal with the band of zeros +* . along the diagonal of one of the triangular +* . blocks. ==== +* + KZS = ( J4-J2 ) - ( NS+1 ) + KNZ = NS + 1 +* +* ==== Horizontal multiply ==== +* + DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + 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 ) +* +* ==== Multiply top of H by U11' ==== +* + CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H bottom of WH ==== +* + CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21' ==== +* + CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U22 ==== +* + 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 ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 180 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U21 ==== +* + 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 ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U22 ==== +* + 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 ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 190 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( WANTZ ) THEN + DO 200 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U12 ==== +* + 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 ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Multiply by U22 ==== +* + 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 ) +* +* ==== Copy the result back to Z ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 200 CONTINUE + END IF + END IF + END IF + 210 CONTINUE +* +* ==== End of ZLAQR5 ==== +* + END
--- a/libcruft/lapack/zlarf.f +++ b/libcruft/lapack/zlarf.f @@ -1,9 +1,8 @@ SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE
--- a/libcruft/lapack/zlarfb.f +++ b/libcruft/lapack/zlarfb.f @@ -1,10 +1,9 @@ SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS
--- a/libcruft/lapack/zlarfg.f +++ b/libcruft/lapack/zlarfg.f @@ -1,9 +1,8 @@ SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
--- a/libcruft/lapack/zlarft.f +++ b/libcruft/lapack/zlarft.f @@ -1,9 +1,8 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV
--- a/libcruft/lapack/zlarfx.f +++ b/libcruft/lapack/zlarfx.f @@ -1,9 +1,8 @@ SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE
--- a/libcruft/lapack/zlartg.f +++ b/libcruft/lapack/zlartg.f @@ -1,9 +1,8 @@ SUBROUTINE ZLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION CS @@ -48,6 +47,9 @@ * * 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel * +* This version has a few statements commented out for thread safety +* (machine parameters are computed on each entry). 10 feb 03, SJH. +* * ===================================================================== * * .. Parameters .. @@ -57,7 +59,7 @@ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL FIRST +* LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, $ SAFMN2, SAFMX2, SCALE @@ -75,10 +77,10 @@ DOUBLE PRECISION ABS1, ABSSQ * .. * .. Save statement .. - SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. - DATA FIRST / .TRUE. / +* DATA FIRST / .TRUE. / * .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) @@ -86,14 +88,14 @@ * .. * .. Executable Statements .. * - IF( FIRST ) THEN - FIRST = .FALSE. +* IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 - END IF +* FIRST = .FALSE. +* END IF SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G
--- a/libcruft/lapack/zlascl.f +++ b/libcruft/lapack/zlascl.f @@ -1,9 +1,8 @@ SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TYPE @@ -62,7 +61,7 @@ * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * -* A (input/output) COMPLEX*16 array, dimension (LDA,M) +* A (input/output) COMPLEX*16 array, dimension (LDA,N) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. *
--- a/libcruft/lapack/zlaset.f +++ b/libcruft/lapack/zlaset.f @@ -1,9 +1,8 @@ SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zlasr.f +++ b/libcruft/lapack/zlasr.f @@ -1,9 +1,8 @@ SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE @@ -17,42 +16,77 @@ * Purpose * ======= * -* ZLASR performs the transformation +* ZLASR applies a sequence of real plane rotations to a complex matrix +* A, from either the left or the right. * -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) +* When SIDE = 'L', the transformation takes the form * -* where A is an m by n complex matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): +* A := P*A * -* When DIRECT = 'F' or 'f' ( Forward sequence ) then +* and when SIDE = 'R', the transformation takes the form * -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then +* A := A*P**T * -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* where P is an orthogonal matrix consisting of a sequence of z plane +* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', +* and P**T is the transpose of P. +* +* When DIRECT = 'F' (Forward sequence), then +* +* P = P(z-1) * ... * P(2) * P(1) +* +* and when DIRECT = 'B' (Backward sequence), then +* +* P = P(1) * P(2) * ... * P(z-1) +* +* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation +* +* R(k) = ( c(k) s(k) ) +* = ( -s(k) c(k) ). +* +* When PIVOT = 'V' (Variable pivot), the rotation is performed +* for the plane (k,k+1), i.e., P(k) has the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears as a rank-2 modification to the identity matrix in +* rows and columns k and k+1. +* +* When PIVOT = 'T' (Top pivot), the rotation is performed for the +* plane (1,k+1), so P(k) has the form +* +* P(k) = ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears in rows and columns 1 and k+1. +* +* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is +* performed for the plane (k,z), giving P(k) the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* +* where R(k) appears in rows and columns k and z. The rotations are +* performed without ever forming P(k) explicitly. * * Arguments * ========= @@ -61,13 +95,7 @@ * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A -* = 'R': Right, compute A:= A*P' -* -* DIRECT (input) CHARACTER*1 -* Specifies whether P is a forward or backward sequence of -* plane rotations. -* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) -* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) +* = 'R': Right, compute A:= A*P**T * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation @@ -76,6 +104,12 @@ * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * +* DIRECT (input) CHARACTER*1 +* Specifies whether P is a forward or backward sequence of +* plane rotations. +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) +* * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. @@ -84,18 +118,22 @@ * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * -* C, S (input) DOUBLE PRECISION arrays, dimension +* C (input) DOUBLE PRECISION array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The cosines c(k) of the plane rotations. +* +* S (input) DOUBLE PRECISION array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* The sines s(k) of the plane rotations. The 2-by-2 plane +* rotation part of the matrix P(k), R(k), has the form +* R(k) = ( c(k) s(k) ) +* ( -s(k) c(k) ). * * A (input/output) COMPLEX*16 array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. +* The M-by-N matrix A. On exit, A is overwritten by P*A if +* SIDE = 'R' or by A*P**T if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M).
--- a/libcruft/lapack/zlassq.f +++ b/libcruft/lapack/zlassq.f @@ -1,9 +1,8 @@ SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, N
--- a/libcruft/lapack/zlaswp.f +++ b/libcruft/lapack/zlaswp.f @@ -1,9 +1,8 @@ SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -41,7 +40,7 @@ * The last element of IPIV for which a row interchange will * be done. * -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) +* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged.
--- a/libcruft/lapack/zlatbs.f +++ b/libcruft/lapack/zlatbs.f @@ -1,10 +1,9 @@ SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO
--- a/libcruft/lapack/zlatrd.f +++ b/libcruft/lapack/zlatrd.f @@ -1,9 +1,8 @@ SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO @@ -32,7 +31,7 @@ * Arguments * ========= * -* UPLO (input) CHARACTER +* UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored: * = 'U': Upper triangular
--- a/libcruft/lapack/zlatrs.f +++ b/libcruft/lapack/zlatrs.f @@ -1,10 +1,9 @@ SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO
--- a/libcruft/lapack/zlauu2.f +++ b/libcruft/lapack/zlauu2.f @@ -1,9 +1,8 @@ SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zlauum.f +++ b/libcruft/lapack/zlauum.f @@ -1,9 +1,8 @@ SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zpbcon.f +++ b/libcruft/lapack/zpbcon.f @@ -1,10 +1,11 @@ SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO @@ -81,6 +82,9 @@ DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM COMPLEX*16 ZDUM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX @@ -88,7 +92,7 @@ EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATBS + EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATBS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG @@ -138,7 +142,7 @@ KASE = 0 NORMIN = 'N' 10 CONTINUE - CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN *
--- a/libcruft/lapack/zpbtf2.f +++ b/libcruft/lapack/zpbtf2.f @@ -1,9 +1,8 @@ SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zpbtrf.f +++ b/libcruft/lapack/zpbtrf.f @@ -1,9 +1,8 @@ SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zpbtrs.f +++ b/libcruft/lapack/zpbtrs.f @@ -1,9 +1,8 @@ SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zpocon.f +++ b/libcruft/lapack/zpocon.f @@ -1,10 +1,11 @@ SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO @@ -72,6 +73,9 @@ DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM COMPLEX*16 ZDUM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX @@ -79,7 +83,7 @@ EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS + EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX @@ -127,7 +131,7 @@ KASE = 0 NORMIN = 'N' 10 CONTINUE - CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN *
--- a/libcruft/lapack/zpotf2.f +++ b/libcruft/lapack/zpotf2.f @@ -1,9 +1,8 @@ SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zpotrf.f +++ b/libcruft/lapack/zpotrf.f @@ -1,9 +1,8 @@ SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zpotri.f +++ b/libcruft/lapack/zpotri.f @@ -1,9 +1,8 @@ SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zpotrs.f +++ b/libcruft/lapack/zpotrs.f @@ -1,9 +1,8 @@ SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zptsv.f +++ b/libcruft/lapack/zptsv.f @@ -1,9 +1,8 @@ SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 25, 1997 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS
--- a/libcruft/lapack/zpttrf.f +++ b/libcruft/lapack/zpttrf.f @@ -1,9 +1,8 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, N @@ -44,7 +43,7 @@ * > 0: if INFO = k, the leading minor of order k is not * positive definite; if k < N, the factorization could not * be completed, while if k = N, the factorization was -* completed, but D(N) = 0. +* completed, but D(N) <= 0. * * ===================================================================== *
--- a/libcruft/lapack/zpttrs.f +++ b/libcruft/lapack/zpttrs.f @@ -1,9 +1,8 @@ SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO
--- a/libcruft/lapack/zptts2.f +++ b/libcruft/lapack/zptts2.f @@ -1,9 +1,8 @@ SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER IUPLO, LDB, N, NRHS
--- a/libcruft/lapack/zrot.f +++ b/libcruft/lapack/zrot.f @@ -1,9 +1,8 @@ SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INCX, INCY, N
--- a/libcruft/lapack/zsteqr.f +++ b/libcruft/lapack/zsteqr.f @@ -1,9 +1,8 @@ SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER COMPZ
--- a/libcruft/lapack/ztrcon.f +++ b/libcruft/lapack/ztrcon.f @@ -1,10 +1,11 @@ SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO @@ -85,6 +86,9 @@ DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM COMPLEX*16 ZDUM * .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX @@ -92,7 +96,7 @@ EXTERNAL LSAME, IZAMAX, DLAMCH, ZLANTR * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS + EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX @@ -157,7 +161,7 @@ END IF KASE = 0 10 CONTINUE - CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN *
--- a/libcruft/lapack/ztrevc.f +++ b/libcruft/lapack/ztrevc.f @@ -1,10 +1,9 @@ SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -22,20 +21,23 @@ * * ZTREVC computes some or all of the right and/or left eigenvectors of * a complex upper triangular matrix T. -* +* Matrices of this type are produced by the Schur factorization of +* a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input unitary -* matrix. If T was obtained from the Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. +* +* T*x = w*x, (y**H)*T = w*(y**H) +* +* where y**H denotes the conjugate transpose of the vector y. +* The eigenvalues are not input to this routine, but are read directly +* from the diagonal of T. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +* input matrix. If Q is the unitary factor that reduces a matrix A to +* Schur form T, then Q*X and Q*Y are the matrices of right and left +* eigenvectors of A. * * Arguments * ========= @@ -48,17 +50,17 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed using the matrices supplied in +* VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* The eigenvector corresponding to the j-th eigenvalue is +* computed if SELECT(j) = .TRUE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. @@ -76,19 +78,16 @@ * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL is lower triangular. The i-th column -* VL(i) of VL is the eigenvector corresponding -* to T(i,i). * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -96,19 +95,16 @@ * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR is upper triangular. The i-th column -* VR(i) of VR is the eigenvector corresponding -* to T(i,i). * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* The leading dimension of the array VR. LDVR >= 1, and if +* SIDE = 'R' or 'B'; LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M.
--- a/libcruft/lapack/ztrexc.f +++ b/libcruft/lapack/ztrexc.f @@ -1,9 +1,8 @@ SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ
--- a/libcruft/lapack/ztrsen.f +++ b/libcruft/lapack/ztrsen.f @@ -1,10 +1,11 @@ SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -92,15 +93,14 @@ * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* If JOB = 'N', WORK is not referenced. Otherwise, -* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= 1; -* if JOB = 'E', LWORK = M*(N-M); -* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). +* if JOB = 'E', LWORK = max(1,M*(N-M)); +* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns @@ -194,6 +194,7 @@ DOUBLE PRECISION EST, RNORM, SCALE * .. * .. Local Arrays .. + INTEGER ISAVE( 3 ) DOUBLE PRECISION RWORK( 1 ) * .. * .. External Functions .. @@ -202,7 +203,7 @@ EXTERNAL LSAME, ZLANGE * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZLACON, ZLACPY, ZTREXC, ZTRSYL + EXTERNAL XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT @@ -318,7 +319,7 @@ EST = ZERO KASE = 0 30 CONTINUE - CALL ZLACON( NN, WORK( NN+1 ), WORK, EST, KASE ) + CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN *
--- a/libcruft/lapack/ztrsyl.f +++ b/libcruft/lapack/ztrsyl.f @@ -1,10 +1,9 @@ SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB @@ -106,7 +105,7 @@ EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL + EXTERNAL DLABAD, XERBLA, ZDSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN @@ -119,11 +118,9 @@ NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. - $ LSAME( TRANA, 'C' ) ) THEN + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 - ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. - $ LSAME( TRANB, 'C' ) ) THEN + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3
--- a/libcruft/lapack/ztrti2.f +++ b/libcruft/lapack/ztrti2.f @@ -1,9 +1,8 @@ SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO
--- a/libcruft/lapack/ztrtri.f +++ b/libcruft/lapack/ztrtri.f @@ -1,9 +1,8 @@ SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO
--- a/libcruft/lapack/ztrtrs.f +++ b/libcruft/lapack/ztrtrs.f @@ -1,10 +1,9 @@ SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO
--- a/libcruft/lapack/zung2l.f +++ b/libcruft/lapack/zung2l.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N
--- a/libcruft/lapack/zung2r.f +++ b/libcruft/lapack/zung2r.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N
--- a/libcruft/lapack/zungbr.f +++ b/libcruft/lapack/zungbr.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER VECT @@ -76,7 +75,7 @@ * reflector H(i) or G(i), which determines Q or P**H, as * returned by ZGEBRD in its array argument TAUQ or TAUP. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zunghr.f +++ b/libcruft/lapack/zunghr.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N @@ -46,7 +45,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEHRD. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zungl2.f +++ b/libcruft/lapack/zungl2.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N
--- a/libcruft/lapack/zunglq.f +++ b/libcruft/lapack/zunglq.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N @@ -49,7 +48,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zungql.f +++ b/libcruft/lapack/zungql.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N @@ -50,7 +49,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER @@ -93,9 +92,6 @@ * Test the input arguments * INFO = 0 - NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 @@ -105,9 +101,22 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQL', -INFO ) RETURN @@ -118,7 +127,6 @@ * Quick return if possible * IF( N.LE.0 ) THEN - WORK( 1 ) = 1 RETURN END IF *
--- a/libcruft/lapack/zungqr.f +++ b/libcruft/lapack/zungqr.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N @@ -50,7 +49,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zungtr.f +++ b/libcruft/lapack/zungtr.f @@ -1,9 +1,8 @@ SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER UPLO @@ -48,7 +47,7 @@ * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZHETRD. * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zunm2r.f +++ b/libcruft/lapack/zunm2r.f @@ -1,10 +1,9 @@ SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS
--- a/libcruft/lapack/zunmbr.f +++ b/libcruft/lapack/zunmbr.f @@ -1,10 +1,9 @@ SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT @@ -98,16 +97,17 @@ * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. +* if SIDE = 'R', LWORK >= max(1,M); +* if N = 0 or M = 0, LWORK >= 1. +* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L', +* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the +* optimal blocksize. (NB = 0 if M = 0 or N = 0.) * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns @@ -155,6 +155,9 @@ NQ = N NW = M END IF + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + NW = 0 + END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN @@ -178,24 +181,28 @@ END IF * IF( INFO.EQ.0 ) THEN - IF( APPLYQ ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) + IF( NW.GT.0 ) THEN + IF( APPLYQ ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF ELSE - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) + IF( LEFT ) THEN + NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF END IF + LWKOPT = MAX( 1, NW*NB ) ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF + LWKOPT = 1 END IF - LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * @@ -203,11 +210,11 @@ CALL XERBLA( 'ZUNMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible * - WORK( 1 ) = 1 IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN *
--- a/libcruft/lapack/zunml2.f +++ b/libcruft/lapack/zunml2.f @@ -1,10 +1,9 @@ SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS
--- a/libcruft/lapack/zunmlq.f +++ b/libcruft/lapack/zunmlq.f @@ -1,10 +1,9 @@ SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -76,7 +75,7 @@ * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER
--- a/libcruft/lapack/zunmqr.f +++ b/libcruft/lapack/zunmqr.f @@ -1,10 +1,9 @@ SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -76,7 +75,7 @@ * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * -* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER