Mercurial > hg > octave-max
changeset 3333:15cddaacbc2d
[project @ 1999-11-03 19:53:59 by jwe]
line wrap: on
line diff
--- a/libcruft/ChangeLog +++ b/libcruft/ChangeLog @@ -1,3 +1,9 @@ +1999-11-03 John W. Eaton <jwe@bevo.che.wisc.edu> + + * Update to Lapack version 3.0. + * lapack/ieeeck.f, lapack/dlasq2.f, lapack/dlasq3.f, + lapack/dlasq5.f, lapack/dlasq6.f: New files. + 1999-10-29 John W. Eaton <jwe@bevo.che.wisc.edu> * misc/lo-error.cc (current_liboctave_warning_handler): Define here.
--- a/libcruft/Makerules.in +++ b/libcruft/Makerules.in @@ -14,7 +14,7 @@ DISTFILES = Makefile.in $(SOURCES) $(SPECIAL) -CRUFT_FSRC = $(wildcard $(srcdir)/*.f) \ +CRUFT_SRC = $(wildcard $(srcdir)/*.f) \ $(wildcard $(srcdir)/*.c) \ $(wildcard $(srcdir)/*.cc) CRUFT_BASE = $(basename $(notdir $(CRUFT_SRC)) )
--- a/libcruft/lapack/dbdsqr.f +++ b/libcruft/lapack/dbdsqr.f @@ -1,10 +1,10 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO @@ -152,9 +152,9 @@ PARAMETER ( MAXITR = 6 ) * .. * .. Local Scalars .. - LOGICAL ROTATE - INTEGER I, IDIR, IROT, ISUB, ITER, IUPLO, J, LL, LLL, - $ M, MAXIT, NM1, NM12, NM13, OLDLL, OLDM + LOGICAL LOWER, ROTATE + INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, + $ 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, @@ -177,12 +177,8 @@ * Test the input parameters. * INFO = 0 - IUPLO = 0 - IF( LSAME( UPLO, 'U' ) ) - $ IUPLO = 1 - IF( LSAME( UPLO, 'L' ) ) - $ IUPLO = 2 - IF( IUPLO.EQ.0 ) THEN + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 @@ -208,7 +204,7 @@ IF( N.EQ.0 ) $ RETURN IF( N.EQ.1 ) - $ GO TO 150 + $ GO TO 160 * * ROTATE is true if any singular vectors desired, false otherwise * @@ -224,6 +220,7 @@ NM1 = N - 1 NM12 = NM1 + NM1 NM13 = NM12 + NM1 + IDIR = 0 * * Get machine constants * @@ -233,7 +230,7 @@ * If matrix lower bidiagonal, rotate to be upper bidiagonal * by applying Givens rotations on the left * - IF( IUPLO.EQ.2 ) THEN + IF( LOWER ) THEN DO 10 I = 1, N - 1 CALL DLARTG( D( I ), E( I ), CS, SN, R ) D( I ) = R @@ -262,10 +259,13 @@ * * Compute approximate maximum, minimum singular values * - SMAX = ABS( D( N ) ) - DO 20 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) ) + SMAX = ZERO + DO 20 I = 1, N + SMAX = MAX( SMAX, ABS( D( I ) ) ) 20 CONTINUE + DO 30 I = 1, N - 1 + SMAX = MAX( SMAX, ABS( E( I ) ) ) + 30 CONTINUE SMINL = ZERO IF( TOL.GE.ZERO ) THEN * @@ -273,15 +273,15 @@ * SMINOA = ABS( D( 1 ) ) IF( SMINOA.EQ.ZERO ) - $ GO TO 40 + $ GO TO 50 MU = SMINOA - DO 30 I = 2, N + DO 40 I = 2, N MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) SMINOA = MIN( SMINOA, MU ) IF( SMINOA.EQ.ZERO ) - $ GO TO 40 - 30 CONTINUE + $ GO TO 50 40 CONTINUE + 50 CONTINUE SMINOA = SMINOA / SQRT( DBLE( N ) ) THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) ELSE @@ -306,14 +306,14 @@ * * Begin main iteration loop * - 50 CONTINUE + 60 CONTINUE * * Check for convergence or exceeding iteration count * IF( M.LE.1 ) - $ GO TO 150 + $ GO TO 160 IF( ITER.GT.MAXIT ) - $ GO TO 190 + $ GO TO 200 * * Find diagonal block of matrix to work on * @@ -321,20 +321,20 @@ $ D( M ) = ZERO SMAX = ABS( D( M ) ) SMIN = SMAX - DO 60 LLL = 1, M + DO 70 LLL = 1, M - 1 LL = M - LLL - IF( LL.EQ.0 ) - $ GO TO 80 ABSS = ABS( D( LL ) ) ABSE = ABS( E( LL ) ) IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) $ D( LL ) = ZERO IF( ABSE.LE.THRESH ) - $ GO TO 70 + $ GO TO 80 SMIN = MIN( SMIN, ABSS ) SMAX = MAX( SMAX, ABSS, ABSE ) - 60 CONTINUE 70 CONTINUE + LL = 0 + GO TO 90 + 80 CONTINUE E( LL ) = ZERO * * Matrix splits since E(LL) = 0 @@ -344,9 +344,9 @@ * Convergence of bottom singular value, return to top of loop * M = M - 1 - GO TO 50 + GO TO 60 END IF - 80 CONTINUE + 90 CONTINUE LL = LL + 1 * * E(LL) through E(M-1) are nonzero, E(LL-1) is zero @@ -372,7 +372,7 @@ $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, $ SINL ) M = M - 2 - GO TO 50 + GO TO 60 END IF * * If working on new submatrix, choose shift direction @@ -402,7 +402,7 @@ IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN E( M-1 ) = ZERO - GO TO 50 + GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN @@ -412,15 +412,15 @@ * MU = ABS( D( LL ) ) SMINL = MU - DO 90 LLL = LL, M - 1 + DO 100 LLL = LL, M - 1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO - GO TO 50 + GO TO 60 END IF SMINLO = SMINL MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) - 90 CONTINUE + 100 CONTINUE END IF * ELSE @@ -431,7 +431,7 @@ IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN E( LL ) = ZERO - GO TO 50 + GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN @@ -441,15 +441,15 @@ * MU = ABS( D( M ) ) SMINL = MU - DO 100 LLL = M - 1, LL, -1 + DO 110 LLL = M - 1, LL, -1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO - GO TO 50 + GO TO 60 END IF SMINLO = SMINL MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) - 100 CONTINUE + 110 CONTINUE END IF END IF OLDLL = LL @@ -498,23 +498,16 @@ * CS = ONE OLDCS = ONE - CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) ) - WORK( 1 ) = CS - WORK( 1+NM1 ) = SN - WORK( 1+NM12 ) = OLDCS - WORK( 1+NM13 ) = OLDSN - IROT = 1 - DO 110 I = LL + 1, M - 1 + DO 120 I = LL, M - 1 CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - E( I-1 ) = OLDSN*R + IF( I.GT.LL ) + $ E( I-1 ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT + 1 - WORK( IROT ) = CS - WORK( IROT+NM1 ) = SN - WORK( IROT+NM12 ) = OLDCS - WORK( IROT+NM13 ) = OLDSN - 110 CONTINUE + WORK( I-LL+1 ) = CS + WORK( I-LL+1+NM1 ) = SN + WORK( I-LL+1+NM12 ) = OLDCS + WORK( I-LL+1+NM13 ) = OLDSN + 120 CONTINUE H = D( M )*CS D( M ) = H*OLDCS E( M-1 ) = H*OLDSN @@ -543,23 +536,16 @@ * CS = ONE OLDCS = ONE - CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) ) - WORK( M-LL ) = CS - WORK( M-LL+NM1 ) = -SN - WORK( M-LL+NM12 ) = OLDCS - WORK( M-LL+NM13 ) = -OLDSN - IROT = M - LL - DO 120 I = M - 1, LL + 1, -1 + DO 130 I = M, LL + 1, -1 CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - E( I ) = OLDSN*R + IF( I.LT.M ) + $ E( I ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT - 1 - WORK( IROT ) = CS - WORK( IROT+NM1 ) = -SN - WORK( IROT+NM12 ) = OLDCS - WORK( IROT+NM13 ) = -OLDSN - 120 CONTINUE + WORK( I-LL ) = CS + WORK( I-LL+NM1 ) = -SN + WORK( I-LL+NM12 ) = OLDCS + WORK( I-LL+NM13 ) = -OLDSN + 130 CONTINUE H = D( LL )*CS D( LL ) = H*OLDCS E( LL ) = H*OLDSN @@ -593,25 +579,10 @@ F = ( ABS( D( LL ) )-SHIFT )* $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) G = E( LL ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( LL ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL ) - G = SINR*D( LL+1 ) - D( LL+1 ) = COSR*D( LL+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL ) = R - F = COSL*E( LL ) + SINL*D( LL+1 ) - D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL ) - G = SINL*E( LL+1 ) - E( LL+1 ) = COSL*E( LL+1 ) - WORK( 1 ) = COSR - WORK( 1+NM1 ) = SINR - WORK( 1+NM12 ) = COSL - WORK( 1+NM13 ) = SINL - IROT = 1 - DO 130 I = LL + 1, M - 2 + DO 140 I = LL, M - 1 CALL DLARTG( F, G, COSR, SINR, R ) - E( I-1 ) = R + IF( I.GT.LL ) + $ E( I-1 ) = R F = COSR*D( I ) + SINR*E( I ) E( I ) = COSR*E( I ) - SINR*D( I ) G = SINR*D( I+1 ) @@ -620,29 +591,15 @@ D( I ) = R F = COSL*E( I ) + SINL*D( I+1 ) D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - IROT = IROT + 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = SINL - 130 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( M-2 ) = R - F = COSR*D( M-1 ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 ) - G = SINR*D( M ) - D( M ) = COSR*D( M ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M-1 ) = R - F = COSL*E( M-1 ) + SINL*D( M ) - D( M ) = COSL*D( M ) - SINL*E( M-1 ) - IROT = IROT + 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = SINL + IF( I.LT.M-1 ) THEN + G = SINL*E( I+1 ) + E( I+1 ) = COSL*E( I+1 ) + END IF + WORK( I-LL+1 ) = COSR + WORK( I-LL+1+NM1 ) = SINR + WORK( I-LL+1+NM12 ) = COSL + WORK( I-LL+1+NM13 ) = SINL + 140 CONTINUE E( M-1 ) = F * * Update singular vectors @@ -670,25 +627,10 @@ F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / $ D( M ) ) G = E( M-1 ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( M ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M ) - G = SINR*D( M-1 ) - D( M-1 ) = COSR*D( M-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M ) = R - F = COSL*E( M-1 ) + SINL*D( M-1 ) - D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 ) - G = SINL*E( M-2 ) - E( M-2 ) = COSL*E( M-2 ) - WORK( M-LL ) = COSR - WORK( M-LL+NM1 ) = -SINR - WORK( M-LL+NM12 ) = COSL - WORK( M-LL+NM13 ) = -SINL - IROT = M - LL - DO 140 I = M - 1, LL + 2, -1 + DO 150 I = M, LL + 1, -1 CALL DLARTG( F, G, COSR, SINR, R ) - E( I ) = R + IF( I.LT.M ) + $ E( I ) = R F = COSR*D( I ) + SINR*E( I-1 ) E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) G = SINR*D( I-1 ) @@ -697,29 +639,15 @@ D( I ) = R F = COSL*E( I-1 ) + SINL*D( I-1 ) D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - IROT = IROT - 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = -SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = -SINL - 140 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( LL+1 ) = R - F = COSR*D( LL+1 ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL+1 ) - G = SINR*D( LL ) - D( LL ) = COSR*D( LL ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL+1 ) = R - F = COSL*E( LL ) + SINL*D( LL ) - D( LL ) = COSL*D( LL ) - SINL*E( LL ) - IROT = IROT - 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = -SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = -SINL + IF( I.GT.LL+1 ) THEN + G = SINL*E( I-2 ) + E( I-2 ) = COSL*E( I-2 ) + END IF + WORK( I-LL ) = COSR + WORK( I-LL+NM1 ) = -SINR + WORK( I-LL+NM12 ) = COSL + WORK( I-LL+NM13 ) = -SINL + 150 CONTINUE E( LL ) = F * * Test convergence @@ -743,12 +671,12 @@ * * QR iteration finished, go back and check convergence * - GO TO 50 + GO TO 60 * * All singular values converged, so make them positive * - 150 CONTINUE - DO 160 I = 1, N + 160 CONTINUE + DO 170 I = 1, N IF( D( I ).LT.ZERO ) THEN D( I ) = -D( I ) * @@ -757,23 +685,23 @@ IF( NCVT.GT.0 ) $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) END IF - 160 CONTINUE + 170 CONTINUE * * Sort the singular values into decreasing order (insertion sort on * singular values, but only one transposition per singular vector) * - DO 180 I = 1, N - 1 + DO 190 I = 1, N - 1 * * Scan for smallest D(I) * ISUB = 1 SMIN = D( 1 ) - DO 170 J = 2, N + 1 - I + DO 180 J = 2, N + 1 - I IF( D( J ).LE.SMIN ) THEN ISUB = J SMIN = D( J ) END IF - 170 CONTINUE + 180 CONTINUE IF( ISUB.NE.N+1-I ) THEN * * Swap singular values and vectors @@ -788,18 +716,18 @@ IF( NCC.GT.0 ) $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) END IF - 180 CONTINUE - GO TO 210 + 190 CONTINUE + GO TO 220 * * Maximum number of iterations exceeded, failure to converge * - 190 CONTINUE + 200 CONTINUE INFO = 0 - DO 200 I = 1, N - 1 + DO 210 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 - 200 CONTINUE 210 CONTINUE + 220 CONTINUE RETURN * * End of DBDSQR
--- a/libcruft/lapack/dgebak.f +++ b/libcruft/lapack/dgebak.f @@ -1,7 +1,7 @@ SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgebal.f +++ b/libcruft/lapack/dgebal.f @@ -1,9 +1,9 @@ SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOB @@ -96,13 +96,16 @@ * * This subroutine is based on the EISPACK routine BALANC. * +* Modified by Tzu-Yi Chen, Computer Science Division, University of +* California at Berkeley, USA +* * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) + PARAMETER ( SCLFAC = 0.8D+1 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * ..
--- a/libcruft/lapack/dgebd2.f +++ b/libcruft/lapack/dgebd2.f @@ -1,6 +1,6 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgebrd.f +++ b/libcruft/lapack/dgebrd.f @@ -1,17 +1,17 @@ SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( LWORK ) + $ TAUQ( * ), WORK( * ) * .. * * Purpose @@ -78,6 +78,11 @@ * For optimum performance LWORK >= (M+N)*NB, 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. @@ -136,15 +141,16 @@ PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN, - $ NX + LOGICAL LQUERY + INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, + $ NBMIN, NX DOUBLE PRECISION WS * .. * .. External Subroutines .. EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC DBLE, MAX, MIN * .. * .. External Functions .. INTEGER ILAENV @@ -155,18 +161,24 @@ * Test the input parameters * INFO = 0 + NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) + LWKOPT = ( M+N )*NB + WORK( 1 ) = DBLE( LWKOPT ) + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'DGEBRD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -181,15 +193,14 @@ LDWRKX = M LDWRKY = N * -* Set the block size NB and the crossover point NX. + IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * - NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) +* Set the crossover point NX. * - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN + NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * - NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN
--- a/libcruft/lapack/dgeesx.f +++ b/libcruft/lapack/dgeesx.f @@ -2,10 +2,10 @@ $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -140,8 +140,9 @@ * N+2*SDIM*(N-SDIM) <= N+N*N/2. * For good performance, LWORK must generally be larger. * -* IWORK (workspace) INTEGER array, dimension (LIWORK) +* IWORK (workspace/output) INTEGER array, dimension (LIWORK) * Not referenced if SENSE = 'N' or 'E'. +* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. @@ -185,8 +186,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, - $ DLACPY, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA + EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, + $ DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -261,6 +262,9 @@ 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 @@ -485,6 +489,12 @@ END IF * WORK( 1 ) = MAXWRK + IF( WANTSV .OR. WANTSB ) THEN + IWORK( 1 ) = SDIM*( N-SDIM ) + ELSE + IWORK( 1 ) = 1 + END IF +* RETURN * * End of DGEESX
--- a/libcruft/lapack/dgeev.f +++ b/libcruft/lapack/dgeev.f @@ -1,10 +1,10 @@ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -98,6 +98,11 @@ * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good * performance, LWORK must generally be larger. * +* 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. @@ -113,7 +118,7 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL SCALEA, WANTVL, WANTVR + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, $ MAXB, MAXWRK, MINWRK, NOUT @@ -125,9 +130,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, - $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, - $ XERBLA + EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, + $ DLASCL, DORGHR, DROT, DSCAL, DTREVC, XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -144,6 +148,7 @@ * Test the input arguments * INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN @@ -193,12 +198,14 @@ END IF WORK( 1 ) = MAXWRK END IF - IF( LWORK.LT.MINWRK ) THEN + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEV ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible
--- a/libcruft/lapack/dgehd2.f +++ b/libcruft/lapack/dgehd2.f @@ -1,6 +1,6 @@ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgehrd.f +++ b/libcruft/lapack/dgehrd.f @@ -1,15 +1,15 @@ SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -56,6 +56,11 @@ * For optimum performance LWORK >= N*NB, 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. @@ -102,7 +107,9 @@ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, LDWORK, NB, NBMIN, NH, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, + $ NH, NX DOUBLE PRECISION EI * .. * .. Local Arrays .. @@ -123,6 +130,10 @@ * Test the input parameters * INFO = 0 + NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN @@ -131,12 +142,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHRD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
--- a/libcruft/lapack/dgelq2.f +++ b/libcruft/lapack/dgelq2.f @@ -1,6 +1,6 @@ SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgelqf.f +++ b/libcruft/lapack/dgelqf.f @@ -1,15 +1,15 @@ SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -50,6 +50,11 @@ * For optimum performance LWORK >= M*NB, 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 @@ -72,7 +77,9 @@ * ===================================================================== * * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA @@ -89,18 +96,24 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELQF', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -111,9 +124,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) NBMIN = 2 NX = 0 IWS = M
--- a/libcruft/lapack/dgelss.f +++ b/libcruft/lapack/dgelss.f @@ -1,10 +1,10 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -86,6 +86,11 @@ * LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) * For good performance, LWORK should generally be larger. * +* 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. @@ -97,9 +102,10 @@ * * .. Parameters .. DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. + LOGICAL LQUERY INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, $ MAXWRK, MINMN, MINWRK, MM, MNTHR @@ -129,6 +135,7 @@ 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 ELSE IF( N.LT.0 ) THEN @@ -149,7 +156,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -166,7 +173,7 @@ * * Path 1 - overdetermined or exactly determined * -* Compute workspace neede for DBDSQR +* Compute workspace needed for DBDSQR * BDSPAC = MAX( 1, 5*N-4 ) MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* @@ -182,7 +189,7 @@ END IF IF( N.GT.M ) THEN * -* Compute workspace neede for DBDSQR +* Compute workspace needed for DBDSQR * BDSPAC = MAX( 1, 5*M-4 ) MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) @@ -225,11 +232,13 @@ END IF * MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK ) + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSS', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -385,9 +394,9 @@ CHUNK = LWORK / N DO 20 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B, LDB, - $ ZERO, WORK, N ) - CALL DLACPY( 'G', N, BL, WORK, N, B, LDB ) + CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ), + $ LDB, ZERO, WORK, N ) + CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB ) 20 CONTINUE ELSE CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) @@ -483,7 +492,8 @@ BL = MIN( NRHS-I+1, CHUNK ) CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, $ B( 1, I ), LDB, ZERO, WORK( IWORK ), N ) - CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B, LDB ) + CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + $ LDB ) 40 CONTINUE ELSE CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
--- a/libcruft/lapack/dgeqpf.f +++ b/libcruft/lapack/dgeqpf.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * -* -- LAPACK test routine (version 2.0) -- +* -- 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 @@ -16,6 +16,8 @@ * Purpose * ======= * +* This routine is deprecated and has been replaced by routine DGEQP3. +* * DGEQPF computes a QR factorization with column pivoting of a * real M-by-N matrix A: A*P = Q*R. *
--- a/libcruft/lapack/dgeqr2.f +++ b/libcruft/lapack/dgeqr2.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgeqrf.f +++ b/libcruft/lapack/dgeqrf.f @@ -1,15 +1,15 @@ SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -51,6 +51,11 @@ * For optimum performance LWORK >= N*NB, 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 @@ -73,7 +78,9 @@ * ===================================================================== * * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA @@ -90,18 +97,24 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRF', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -112,9 +125,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) NBMIN = 2 NX = 0 IWS = N
--- a/libcruft/lapack/dgesv.f +++ b/libcruft/lapack/dgesv.f @@ -1,6 +1,6 @@ SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgesvd.f +++ b/libcruft/lapack/dgesvd.f @@ -1,10 +1,10 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -118,6 +118,11 @@ * LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)-4). * For good performance, LWORK should generally be larger. * +* 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. @@ -133,8 +138,8 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, WNTVA, - $ WNTVAS, WNTVN, WNTVO, WNTVS + LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, + $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, @@ -176,6 +181,7 @@ WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) MINWRK = 1 + LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 @@ -202,7 +208,8 @@ * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. LWORK.GE.1 .AND. M.GT.0 .AND. N.GT.0 ) THEN + IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. + $ N.GT.0 ) THEN IF( M.GE.N ) THEN * * Compute space needed for DBDSQR @@ -553,12 +560,14 @@ WORK( 1 ) = MAXWRK END IF * - IF( LWORK.LT.MINWRK ) THEN + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible
--- a/libcruft/lapack/dgetf2.f +++ b/libcruft/lapack/dgetf2.f @@ -1,6 +1,6 @@ SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgetrf.f +++ b/libcruft/lapack/dgetrf.f @@ -1,6 +1,6 @@ SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgetrs.f +++ b/libcruft/lapack/dgetrs.f @@ -1,6 +1,6 @@ SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dggbak.f +++ b/libcruft/lapack/dggbak.f @@ -1,7 +1,7 @@ SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dggbal.f +++ b/libcruft/lapack/dggbal.f @@ -1,7 +1,7 @@ SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dgghrd.f +++ b/libcruft/lapack/dgghrd.f @@ -1,7 +1,7 @@ SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dhgeqz.f +++ b/libcruft/lapack/dhgeqz.f @@ -2,10 +2,10 @@ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB @@ -179,6 +179,11 @@ * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * +* 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 @@ -209,7 +214,8 @@ $ SAFETY = 1.0D+2 ) * .. * .. Local Scalars .. - LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ + LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, + $ LQUERY INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, $ JR, MAXIT @@ -282,6 +288,8 @@ * Check Argument Values * INFO = 0 + WORK( 1 ) = MAX( 1, N ) + LQUERY = ( LWORK.EQ.-1 ) IF( ISCHUR.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.EQ.0 ) THEN @@ -302,12 +310,14 @@ INFO = -15 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -17 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -19 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DHGEQZ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible
--- a/libcruft/lapack/dhseqr.f +++ b/libcruft/lapack/dhseqr.f @@ -1,10 +1,10 @@ SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPZ, JOB @@ -93,10 +93,16 @@ * The leading dimension of the array Z. * LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. * -* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER -* This argument is currently redundant. +* The dimension of the array WORK. LWORK >= max(1,N). +* +* 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 @@ -117,7 +123,7 @@ PARAMETER ( NSMAX = 15, LDS = NSMAX ) * .. * .. Local Scalars .. - LOGICAL INITZ, WANTT, WANTZ + 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 @@ -132,8 +138,8 @@ EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2 * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLABAD, DLACPY, DLAHQR, DLARFG, - $ DLARFX, DLASET, DSCAL, XERBLA + EXTERNAL DCOPY, DGEMV, DLACPY, DLAHQR, DLARFG, DLARFX, + $ DLASET, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN @@ -147,6 +153,8 @@ WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) * 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 @@ -161,10 +169,14 @@ INFO = -7 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 CALL XERBLA( 'DHSEQR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Initialize Z, if necessary @@ -447,6 +459,7 @@ GO TO 50 * 170 CONTINUE + WORK( 1 ) = MAX( 1, N ) RETURN * * End of DHSEQR
--- a/libcruft/lapack/dlabad.f +++ b/libcruft/lapack/dlabad.f @@ -1,6 +1,6 @@ SUBROUTINE DLABAD( SMALL, LARGE ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 @@ -12,7 +12,7 @@ * Purpose * ======= * -* DLABAD takes as input the values computed by SLAMCH for underflow and +* DLABAD takes as input the values computed by DLAMCH for underflow and * overflow, and returns the square root of each of these values if the * log of LARGE is sufficiently large. This subroutine is intended to * identify machines with a large exponent range, such as the Crays, and
--- a/libcruft/lapack/dlabrd.f +++ b/libcruft/lapack/dlabrd.f @@ -1,7 +1,7 @@ SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlacon.f +++ b/libcruft/lapack/dlacon.f @@ -1,6 +1,6 @@ SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlacpy.f +++ b/libcruft/lapack/dlacpy.f @@ -1,6 +1,6 @@ SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dladiv.f +++ b/libcruft/lapack/dladiv.f @@ -1,6 +1,6 @@ SUBROUTINE DLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlae2.f +++ b/libcruft/lapack/dlae2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlaev2.f +++ b/libcruft/lapack/dlaev2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlaexc.f +++ b/libcruft/lapack/dlaexc.f @@ -1,7 +1,7 @@ SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlag2.f +++ b/libcruft/lapack/dlag2.f @@ -1,7 +1,7 @@ SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlahqr.f +++ b/libcruft/lapack/dlahqr.f @@ -1,10 +1,10 @@ SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. LOGICAL WANTT, WANTZ @@ -90,19 +90,26 @@ * elements i+1:ihi of WR and WI contain those eigenvalues * which have been successfully computed. * +* Further Details +* =============== +* +* 2-96 Based on modifications by +* David Day, Sandia National Laboratory, USA +* * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D0 ) DOUBLE PRECISION DAT1, DAT2 PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ - DOUBLE PRECISION CS, 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 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 * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ), WORK( 1 ) @@ -112,10 +119,10 @@ EXTERNAL DLAMCH, DLANHS * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT + EXTERNAL DCOPY, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN + INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * @@ -211,22 +218,40 @@ * Exceptional shift. * S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) - H44 = DAT1*S + H44 = DAT1*S + H( I, I ) H33 = H44 H43H34 = DAT2*S*S ELSE * -* Prepare to use Wilkinson's double shift +* 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 +* + 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 ) + ELSE + H44 = SIGN( DISC, AVE ) + AVE + END IF + H33 = H44 + H43H34 = ZERO + END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 40 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.
--- a/libcruft/lapack/dlahrd.f +++ b/libcruft/lapack/dlahrd.f @@ -1,9 +1,9 @@ SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -53,7 +53,7 @@ * The scalar factors of the elementary reflectors. See Further * Details. * -* T (output) DOUBLE PRECISION array, dimension (NB,NB) +* T (output) DOUBLE PRECISION array, dimension (LDT,NB) * The upper triangular matrix T. * * LDT (input) INTEGER
--- a/libcruft/lapack/dlaln2.f +++ b/libcruft/lapack/dlaln2.f @@ -1,7 +1,7 @@ SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlamch.f +++ b/libcruft/lapack/dlamch.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 @@ -125,3 +125,733 @@ * End of DLAMCH * END +* +************************************************************************ +* + 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 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* +* Purpose +* ======= +* +* DLAMC1 determines the machine parameters given by BETA, T, RND, and +* IEEE1. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* IEEE1 (output) LOGICAL +* Specifies whether rounding appears to be done in the IEEE +* 'round to nearest' style. +* +* Further Details +* =============== +* +* The routine is based on the routine ENVRON by Malcolm and +* incorporates suggestions by Gentleman and Marovich. See +* +* Malcolm M. A. (1972) Algorithms to reveal properties of +* floating-point arithmetic. Comms. of the ACM, 15, 949-951. +* +* Gentleman W. M. and Marovich S. B. (1974) More on algorithms +* that reveal properties of floating point arithmetic units. +* Comms. of the ACM, 17, 276-277. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ONE = 1 +* +* LBETA, LIEEE1, LT and LRND are the local values of BETA, +* IEEE1, T and RND. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* Compute a = 2.0**m with the smallest positive integer m such +* that +* +* fl( a + 1.0 ) = a. +* + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + B = 1 + C = DLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = DLAMC3( A, B ) + GO TO 20 + END IF +*+ END WHILE +* +* Now compute the base. a and c are neighbouring floating point +* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so +* their difference is beta. Adding 0.25 to c is to ensure that it +* is truncated to beta and not ( beta - 1 ). +* + QTR = ONE / 4 + SAVEC = C + C = DLAMC3( C, -A ) + LBETA = C + QTR +* +* Now determine whether rounding or chopping occurs, by adding a +* bit less than beta/2 and a bit more than beta/2 to a. +* + B = LBETA + F = DLAMC3( B / 2, -B / 100 ) + C = DLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = DLAMC3( B / 2, B / 100 ) + C = DLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.A ) ) + $ LRND = .FALSE. +* +* Try and decide whether rounding is done in the IEEE 'round to +* nearest' style. B/2 is half a unit in the last place of the two +* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit +* zero, and SAVEC is odd. Thus adding B/2 to A should not change +* A, but adding B/2 to SAVEC should change SAVEC. +* + T1 = DLAMC3( B / 2, A ) + T2 = DLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND +* +* Now find the mantissa, t. It should be the integer part of +* log to the base beta of a, however it is safer to determine t +* by powering. So we find t as the smallest positive integer for +* which +* +* fl( beta**t + 1.0 ) = 1.0. +* + LT = 0 + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + RETURN +* +* End of DLAMC1 +* + END +* +************************************************************************ +* + 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 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* +* Purpose +* ======= +* +* DLAMC2 determines the machine parameters specified in its argument +* list. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* EPS (output) DOUBLE PRECISION +* The smallest positive number such that +* +* fl( 1.0 - EPS ) .LT. 1.0, +* +* where fl denotes the computed value. +* +* EMIN (output) INTEGER +* The minimum exponent before (gradual) underflow occurs. +* +* RMIN (output) DOUBLE PRECISION +* The smallest normalized number for the machine, given by +* BASE**( EMIN - 1 ), where BASE is the floating point value +* of BETA. +* +* EMAX (output) INTEGER +* The maximum exponent before overflow occurs. +* +* RMAX (output) DOUBLE PRECISION +* The largest positive number for the machine, given by +* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point +* value of BETA. +* +* Further Details +* =============== +* +* The computation of EPS is based on a routine PARANOIA by +* W. Kahan of the University of California at Berkeley. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL DLAMC1, DLAMC4, DLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ZERO = 0 + ONE = 1 + TWO = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of +* BETA, T, RND, EPS, EMIN and RMIN. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. +* + CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = DLAMC3( B, -HALF ) + THIRD = DLAMC3( SIXTH, SIXTH ) + B = DLAMC3( THIRD, -HALF ) + B = DLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = DLAMC3( HALF, -C ) + B = DLAMC3( HALF, C ) + C = DLAMC3( HALF, -B ) + B = DLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.LEPS ) + $ LEPS = A +* +* Computation of EPS complete. +* +* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). +* Keep dividing A by BETA until (gradual) underflow occurs. This +* is detected when we cannot recover the previous A. +* + RBASE = ONE / LBETA + SMALL = ONE + DO 20 I = 1, 3 + SMALL = DLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = DLAMC3( ONE, SMALL ) + CALL DLAMC4( NGPMIN, ONE, LBETA ) + CALL DLAMC4( NGNMIN, -ONE, LBETA ) + CALL DLAMC4( GPMIN, A, LBETA ) + CALL DLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + LEMIN = NGPMIN - 1 + LT + IEEE = .TRUE. +* ( Non twos-complement machines, with gradual underflow; +* e.g., IEEE standard followers ) + ELSE + LEMIN = MIN( NGPMIN, GPMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) +* ( Twos-complement machines, no gradual underflow; +* e.g., CYBER 205 ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT +* ( Twos-complement machines with gradual underflow; +* no known machine ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* Assume IEEE arithmetic if we found denormalised numbers above, +* or if arithmetic seems to round in the IEEE style, determined +* in routine DLAMC1. A true IEEE machine should have both things +* true; however, faulty machines may have one or the other. +* + IEEE = IEEE .OR. LIEEE1 +* +* Compute RMIN by successive division by BETA. We could compute +* RMIN as BASE**( EMIN - 1 ), but some machines underflow during +* this computation. +* + LRMIN = 1 + DO 30 I = 1, 1 - LEMIN + LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call DLAMC5 to compute EMAX and RMAX. +* + CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of DLAMC2 +* + END +* +************************************************************************ +* + 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 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* +* Purpose +* ======= +* +* DLAMC3 is intended to force A and B to be stored prior to doing +* the addition of A and B , for use in situations where optimizers +* might hold one of these in a register. +* +* Arguments +* ========= +* +* A, B (input) DOUBLE PRECISION +* The values A and B. +* +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ +* + 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 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* +* Purpose +* ======= +* +* DLAMC4 is a service routine for DLAMC2. +* +* Arguments +* ========= +* +* EMIN (output) EMIN +* The minimum exponent before (gradual) underflow, computed by +* setting A = START and dividing by BASE until the previous A +* can not be recovered. +* +* START (input) DOUBLE PRECISION +* The starting point for determining EMIN. +* +* BASE (input) INTEGER +* The base of the machine. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = DLAMC3( A*RBASE, ZERO ) + C1 = A + C2 = A + D1 = A + D2 = A +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = DLAMC3( A / BASE, ZERO ) + C1 = DLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = DLAMC3( A*RBASE, ZERO ) + C2 = DLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of DLAMC4 +* + END +* +************************************************************************ +* + 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 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* +* Purpose +* ======= +* +* DLAMC5 attempts to compute RMAX, the largest machine floating-point +* number, without overflow. It assumes that EMAX + abs(EMIN) sum +* approximately to a power of 2. It will fail on machines where this +* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, +* EMAX = 28718). It will also fail if the value supplied for EMIN is +* too large (i.e. too close to zero), probably with overflow. +* +* Arguments +* ========= +* +* BETA (input) INTEGER +* The base of floating-point arithmetic. +* +* P (input) INTEGER +* The number of base BETA digits in the mantissa of a +* floating-point value. +* +* EMIN (input) INTEGER +* The minimum exponent before (gradual) underflow. +* +* IEEE (input) LOGICAL +* A logical flag specifying whether or not the arithmetic +* system is thought to comply with the IEEE standard. +* +* EMAX (output) INTEGER +* The largest exponent before overflow +* +* RMAX (output) DOUBLE PRECISION +* The largest machine floating-point number. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* First compute LEXP and UEXP, two powers of 2 that bound +* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum +* approximately to the bound that is closest to abs(EMIN). +* (EMAX is the exponent of the required number RMAX). +* + LEXP = 1 + EXBITS = 1 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* Now -LEXP is less than or equal to EMIN, and -UEXP is greater +* than or equal to EMIN. EXBITS is the number of bits needed to +* store the exponent. +* + IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* Either there are an odd number of bits used to store a +* floating-point number, which is unlikely, or some bits are +* not used in the representation of numbers, which is possible, +* (e.g. Cray machines) or the mantissa has an implicit bit, +* (e.g. IEEE machines, Dec Vax machines), which is perhaps the +* most likely. We have to assume the last alternative. +* If this is true, then we need to reduce EMAX by one because +* there must be some way of representing zero in an implicit-bit +* system. On machines like Cray, we are reducing EMAX by one +* unnecessarily. +* + EMAX = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* Now create RMAX, the largest machine number, which should +* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . +* +* First compute 1.0 - BETA**(-P), being careful that the +* result is less than 1.0 . +* + RECBAS = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = DLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = DLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of DLAMC5 +* + END
--- a/libcruft/lapack/dlange.f +++ b/libcruft/lapack/dlange.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlanhs.f +++ b/libcruft/lapack/dlanhs.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlanst.f +++ b/libcruft/lapack/dlanst.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlansy.f +++ b/libcruft/lapack/dlansy.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlanv2.f +++ b/libcruft/lapack/dlanv2.f @@ -1,9 +1,9 @@ SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN @@ -39,38 +39,45 @@ * RT2R (output) DOUBLE PRECISION * RT2I (output) DOUBLE PRECISION * The real and imaginary parts of the eigenvalues. If the -* eigenvalues are both real, abs(RT1R) >= abs(RT2R); if the * eigenvalues are a complex conjugate pair, RT1I > 0. * * CS (output) DOUBLE PRECISION * SN (output) DOUBLE PRECISION * Parameters of the rotation matrix. * +* Further Details +* =============== +* +* Modified by V. Sima, Research Institute for Informatics, Bucharest, +* Romania, to reduce the risk of cancellation errors, +* when computing real eigenvalues, and to ensure, if possible, that +* abs(RT1R) >= abs(RT2R). +* * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION MULTPL + PARAMETER ( MULTPL = 4.0D+0 ) * .. * .. Local Scalars .. - DOUBLE PRECISION AA, BB, CC, CS1, DD, P, SAB, SAC, SIGMA, SN1, - $ TAU, TEMP + DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, + $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z * .. * .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT + INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * -* Initialize CS and SN -* - CS = ONE - SN = ZERO -* + EPS = DLAMCH( 'P' ) IF( C.EQ.ZERO ) THEN + CS = ONE + SN = ZERO GO TO 10 * ELSE IF( B.EQ.ZERO ) THEN @@ -85,74 +92,98 @@ B = -C C = ZERO GO TO 10 - ELSE IF( (A-D).EQ.ZERO .AND. SIGN( ONE, B ).NE. - $ SIGN( ONE, C ) ) THEN + ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) + $ THEN + CS = ONE + SN = ZERO GO TO 10 ELSE * -* Make diagonal elements equal -* TEMP = A - D P = HALF*TEMP - SIGMA = B + C - TAU = DLAPY2( SIGMA, TEMP ) - CS1 = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) - SN1 = -( P / ( TAU*CS1 ) )*SIGN( ONE, SIGMA ) + BCMAX = MAX( ABS( B ), ABS( C ) ) + BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) + SCALE = MAX( ABS( P ), BCMAX ) + Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS +* +* If Z is of the order of the machine accuracy, postpone the +* decision on the nature of eigenvalues * -* Compute [ AA BB ] = [ A B ] [ CS1 -SN1 ] -* [ CC DD ] [ C D ] [ SN1 CS1 ] + IF( Z.GE.MULTPL*EPS ) THEN +* +* Real eigenvalues. Compute A and D. * - AA = A*CS1 + B*SN1 - BB = -A*SN1 + B*CS1 - CC = C*CS1 + D*SN1 - DD = -C*SN1 + D*CS1 + Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) + A = D + Z + D = D - ( BCMAX / Z )*BCMIS +* +* Compute B and the rotation matrix * -* Compute [ A B ] = [ CS1 SN1 ] [ AA BB ] -* [ C D ] [-SN1 CS1 ] [ CC DD ] + TAU = DLAPY2( C, Z ) + CS = Z / TAU + SN = C / TAU + B = B - C + C = ZERO + ELSE * - A = AA*CS1 + CC*SN1 - B = BB*CS1 + DD*SN1 - C = -AA*SN1 + CC*CS1 - D = -BB*SN1 + DD*CS1 +* Complex eigenvalues, or real (almost) equal eigenvalues. +* Make diagonal elements equal. * -* Accumulate transformation + SIGMA = B + C + TAU = DLAPY2( SIGMA, TEMP ) + CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) + SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA ) * - TEMP = CS*CS1 - SN*SN1 - SN = CS*SN1 + SN*CS1 - CS = TEMP +* Compute [ AA BB ] = [ A B ] [ CS -SN ] +* [ CC DD ] [ C D ] [ SN CS ] * - TEMP = HALF*( A+D ) - A = TEMP - D = TEMP + AA = A*CS + B*SN + BB = -A*SN + B*CS + CC = C*CS + D*SN + DD = -C*SN + D*CS +* +* Compute [ A B ] = [ CS SN ] [ AA BB ] +* [ C D ] [-SN CS ] [ CC DD ] * - IF( C.NE.ZERO ) THEN - IF( B.NE.ZERO ) THEN - IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN + A = AA*CS + CC*SN + B = BB*CS + DD*SN + C = -AA*SN + CC*CS + D = -BB*SN + DD*CS * -* Real eigenvalues: reduce to upper triangular form + TEMP = HALF*( A+D ) + A = TEMP + D = TEMP +* + IF( C.NE.ZERO ) THEN + IF( B.NE.ZERO ) THEN + IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN * - SAB = SQRT( ABS( B ) ) - SAC = SQRT( ABS( C ) ) - P = SIGN( SAB*SAC, C ) - TAU = ONE / SQRT( ABS( B+C ) ) - A = TEMP + P - D = TEMP - P - B = B - C +* Real eigenvalues: reduce to upper triangular form +* + SAB = SQRT( ABS( B ) ) + SAC = SQRT( ABS( C ) ) + P = SIGN( SAB*SAC, C ) + TAU = ONE / SQRT( ABS( B+C ) ) + A = TEMP + P + D = TEMP - P + B = B - C + C = ZERO + CS1 = SAB*TAU + SN1 = SAC*TAU + TEMP = CS*CS1 - SN*SN1 + SN = CS*SN1 + SN*CS1 + CS = TEMP + END IF + ELSE + B = -C C = ZERO - CS1 = SAB*TAU - SN1 = SAC*TAU - TEMP = CS*CS1 - SN*SN1 - SN = CS*SN1 + SN*CS1 - CS = TEMP + TEMP = CS + CS = -SN + SN = TEMP END IF - ELSE - B = -C - C = ZERO - TEMP = CS - CS = -SN - SN = TEMP END IF END IF +* END IF * 10 CONTINUE
--- a/libcruft/lapack/dlapy2.f +++ b/libcruft/lapack/dlapy2.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlapy3.f +++ b/libcruft/lapack/dlapy3.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlarf.f +++ b/libcruft/lapack/dlarf.f @@ -1,6 +1,6 @@ SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlarfb.f +++ b/libcruft/lapack/dlarfb.f @@ -1,7 +1,7 @@ SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlarfg.f +++ b/libcruft/lapack/dlarfg.f @@ -1,6 +1,6 @@ SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlarft.f +++ b/libcruft/lapack/dlarft.f @@ -1,6 +1,6 @@ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlarfx.f +++ b/libcruft/lapack/dlarfx.f @@ -1,6 +1,6 @@ SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlartg.f +++ b/libcruft/lapack/dlartg.f @@ -1,6 +1,6 @@ SUBROUTINE DLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlas2.f +++ b/libcruft/lapack/dlas2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlascl.f +++ b/libcruft/lapack/dlascl.f @@ -1,6 +1,6 @@ SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlaset.f +++ b/libcruft/lapack/dlaset.f @@ -1,6 +1,6 @@ SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlasq1.f +++ b/libcruft/lapack/dlasq1.f @@ -1,9 +1,9 @@ SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, N @@ -12,81 +12,78 @@ DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. * -* Purpose -* ======= +* Purpose +* ======= * -* DLASQ1 computes the singular values of a real N-by-N bidiagonal -* matrix with diagonal D and off-diagonal E. The singular values are -* computed to high relative accuracy, barring over/underflow or -* denormalization. The algorithm is described in +* DLASQ1 computes the singular values of a real N-by-N bidiagonal +* matrix with diagonal D and off-diagonal E. The singular values +* are computed to high relative accuracy, in the absence of +* denormalization, underflow and overflow. The algorithm was first +* presented in * -* "Accurate singular values and differential qd algorithms," by -* K. V. Fernando and B. N. Parlett, -* Numer. Math., Vol-67, No. 2, pp. 191-230,1994. +* "Accurate singular values and differential qd algorithms" by K. V. +* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, +* 1994, +* +* and the present implementation is described in "An implementation of +* dqds", LAPACK technical report. * -* See also -* "Implementation of differential qd algorithms," by -* K. V. Fernando and B. N. Parlett, Technical Report, -* Department of Mathematics, University of California at Berkeley, -* 1994 (Under preparation). +* Note : DLASQ1 works only on machines which follow ieee-754 +* floating-point standard in their handling of infinities and NaNs. +* Normal execution of DLASQ1 may create NaNs and infinities and hence +* may abort due to a floating point exception in environments which +* do not conform to the ieee standard. * -* Arguments -* ========= +* Arguments +* ========= * -* N (input) INTEGER -* The number of rows and columns in the matrix. N >= 0. +* N (input) INTEGER +* The number of rows and columns in the matrix. N >= 0. * -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, D contains the diagonal elements of the -* bidiagonal matrix whose SVD is desired. On normal exit, -* D contains the singular values in decreasing order. +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, D contains the diagonal elements of the +* bidiagonal matrix whose SVD is desired. On normal exit, +* D contains the singular values in decreasing order. * -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, elements E(1:N-1) contain the off-diagonal elements -* of the bidiagonal matrix whose SVD is desired. -* On exit, E is overwritten. +* E (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, elements E(1:N-1) contain the off-diagonal elements +* of the bidiagonal matrix whose SVD is desired. +* On exit, E is overwritten. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) * -* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm did not converge; i -* specifies how many superdiagonals did not converge. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: the algorithm failed +* = 1, a split was marked by a positive value in E +* = 2, current block of Z not diagonalized after 30*N +* iterations (in inner while loop) +* = 3, termination criterion of outer while loop not met +* (program created more than N unreduced blocks) * * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HUNDRD - PARAMETER ( HUNDRD = 100.0D0 ) - DOUBLE PRECISION TWO56 - PARAMETER ( TWO56 = 256.0D0 ) * .. * .. Local Scalars .. - LOGICAL RESTRT - INTEGER I, IERR, J, KE, KEND, M, NY - DOUBLE PRECISION DM, DX, EPS, SCL, SFMIN, SIG1, SIG2, SIGMN, - $ SIGMX, SMALL2, THRESH, TOL, TOL2, TOLMUL + INTEGER I, IINFO + DOUBLE PRECISION EPS, SCALE, SFMIN, SIGMN, SIGMX +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA -* .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT + INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. +* INFO = 0 IF( N.LT.0 ) THEN INFO = -2 @@ -104,117 +101,54 @@ RETURN END IF * -* Estimate the largest singular value +* Estimate the largest singular value. * SIGMX = ZERO DO 10 I = 1, N - 1 + D( I ) = ABS( D( I ) ) SIGMX = MAX( SIGMX, ABS( E( I ) ) ) 10 CONTINUE + D( N ) = ABS( D( N ) ) * -* Early return if sigmx is zero (matrix is already diagonal) +* Early return if SIGMX is zero (matrix is already diagonal). * - IF( SIGMX.EQ.ZERO ) - $ GO TO 70 + IF( SIGMX.EQ.ZERO ) THEN + CALL DLASRT( 'D', N, D, IINFO ) + GO TO 50 + END IF * DO 20 I = 1, N - D( I ) = ABS( D( I ) ) SIGMX = MAX( SIGMX, D( I ) ) 20 CONTINUE * -* Get machine parameters -* - EPS = DLAMCH( 'EPSILON' ) - SFMIN = DLAMCH( 'SAFE MINIMUM' ) -* -* Compute singular values to relative accuracy TOL -* It is assumed that tol**2 does not underflow. -* - TOLMUL = MAX( TEN, MIN( HUNDRD, EPS**( -MEIGTH ) ) ) - TOL = TOLMUL*EPS - TOL2 = TOL**2 -* - THRESH = SIGMX*SQRT( SFMIN )*TOL +* Copy D and E into WORK (in the Z format) and scale (squaring the +* input data makes scaling by a power of the radix pointless). * -* Scale matrix so the square of the largest element is -* 1 / ( 256 * SFMIN ) + EPS = DLAMCH( 'Precision' ) + SFMIN = DLAMCH( 'Safe minimum' ) + SCALE = SQRT( EPS / SFMIN ) + CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) + CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) + CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, + $ IINFO ) * - SCL = SQRT( ONE / ( TWO56*SFMIN ) ) - SMALL2 = ONE / ( TWO56*TOLMUL**2 ) - CALL DCOPY( N, D, 1, WORK( 1 ), 1 ) - CALL DCOPY( N-1, E, 1, WORK( N+1 ), 1 ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N, 1, WORK( 1 ), N, IERR ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N-1, 1, WORK( N+1 ), N-1, - $ IERR ) -* -* Square D and E (the input for the qd algorithm) -* - DO 30 J = 1, 2*N - 1 - WORK( J ) = WORK( J )**2 - 30 CONTINUE -* -* Apply qd algorithm +* Compute the q's and e's. * - M = 0 - E( N ) = ZERO - DX = WORK( 1 ) - DM = DX - KE = 0 - RESTRT = .FALSE. - DO 60 I = 1, N - IF( ABS( E( I ) ).LE.THRESH .OR. WORK( N+I ).LE.TOL2* - $ ( DM / DBLE( I-M ) ) ) THEN - NY = I - M - IF( NY.EQ.1 ) THEN - GO TO 50 - ELSE IF( NY.EQ.2 ) THEN - CALL DLAS2( D( M+1 ), E( M+1 ), D( M+2 ), SIG1, SIG2 ) - D( M+1 ) = SIG1 - D( M+2 ) = SIG2 - ELSE - KEND = KE + 1 - M - CALL DLASQ2( NY, D( M+1 ), E( M+1 ), WORK( M+1 ), - $ WORK( M+N+1 ), EPS, TOL2, SMALL2, DM, KEND, - $ INFO ) + DO 30 I = 1, 2*N - 1 + WORK( I ) = WORK( I )**2 + 30 CONTINUE + WORK( 2*N ) = ZERO * -* Return, INFO = number of unconverged superdiagonals -* - IF( INFO.NE.0 ) THEN - INFO = INFO + I - RETURN - END IF -* -* Undo scaling + CALL DLASQ2( N, WORK, INFO ) * - DO 40 J = M + 1, M + NY - D( J ) = SQRT( D( J ) ) - 40 CONTINUE - CALL DLASCL( 'G', 0, 0, SCL, SIGMX, NY, 1, D( M+1 ), NY, - $ IERR ) - END IF - 50 CONTINUE - M = I - IF( I.NE.N ) THEN - DX = WORK( I+1 ) - DM = DX - KE = I - RESTRT = .TRUE. - END IF - END IF - IF( I.NE.N .AND. .NOT.RESTRT ) THEN - DX = WORK( I+1 )*( DX / ( DX+WORK( N+I ) ) ) - IF( DM.GT.DX ) THEN - DM = DX - KE = I - END IF - END IF - RESTRT = .FALSE. - 60 CONTINUE - KEND = KE + 1 + IF( INFO.EQ.0 ) THEN + DO 40 I = 1, N + D( I ) = SQRT( WORK( I ) ) + 40 CONTINUE + CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) + END IF * -* Sort the singular values into decreasing order -* - 70 CONTINUE - CALL DLASRT( 'D', N, D, INFO ) + 50 CONTINUE RETURN * * End of DLASQ1
--- a/libcruft/lapack/dlasq2.f +++ b/libcruft/lapack/dlasq2.f @@ -1,267 +1,424 @@ - SUBROUTINE DLASQ2( M, Q, E, QQ, EE, EPS, TOL2, SMALL2, SUP, KEND, - $ INFO ) + SUBROUTINE DLASQ2( N, Z, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. - INTEGER INFO, KEND, M - DOUBLE PRECISION EPS, SMALL2, SUP, TOL2 + INTEGER INFO, N * .. * .. Array Arguments .. - DOUBLE PRECISION E( * ), EE( * ), Q( * ), QQ( * ) + DOUBLE PRECISION Z( * ) * .. * -* Purpose -* ======= +* Purpose +* ======= * -* DLASQ2 computes the singular values of a real N-by-N unreduced -* bidiagonal matrix with squared diagonal elements in Q and -* squared off-diagonal elements in E. The singular values are -* computed to relative accuracy TOL, barring over/underflow or -* denormalization. -* -* Arguments -* ========= +* DLASQ2 computes all the eigenvalues of the symmetric positive +* definite tridiagonal matrix associated with the qd array Z to high +* relative accuracy are computed to high relative accuracy, in the +* absence of denormalization, underflow and overflow. * -* M (input) INTEGER -* The number of rows and columns in the matrix. M >= 0. -* -* Q (output) DOUBLE PRECISION array, dimension (M) -* On normal exit, contains the squared singular values. +* To see the relation of Z to the tridiagonal matrix, let L be a +* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and +* let U be an upper bidiagonal matrix with 1's above and diagonal +* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the +* symmetric tridiagonal to which it is similar. * -* E (workspace) DOUBLE PRECISION array, dimension (M) +* Note : DLASQ2 works only on machines which follow ieee-754 +* floating-point standard in their handling of infinities and NaNs. +* Normal execution of DLASQ2 may create NaNs and infinities and hence +* may abort due to a floating point exception in environments which +* do not conform to the ieee standard. * -* QQ (input/output) DOUBLE PRECISION array, dimension (M) -* On entry, QQ contains the squared diagonal elements of the -* bidiagonal matrix whose SVD is desired. -* On exit, QQ is overwritten. +* Arguments +* ========= +* +* N (input) INTEGER +* The number of rows and columns in the matrix. N >= 0. * -* EE (input/output) DOUBLE PRECISION array, dimension (M) -* On entry, EE(1:N-1) contains the squared off-diagonal -* elements of the bidiagonal matrix whose SVD is desired. -* On exit, EE is overwritten. -* -* EPS (input) DOUBLE PRECISION -* Machine epsilon. -* -* TOL2 (input) DOUBLE PRECISION -* Desired relative accuracy of computed eigenvalues -* as defined in DLASQ1. +* Z (workspace) DOUBLE PRECISION array, dimension ( 4*N ) +* On entry Z holds the qd array. On exit, entries 1 to N hold +* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the +* trace, Z( 2*N+2 ) holds the sum of the eigenvalues, Z( 2*N+3 ) +* holds the iteration count, Z( 2*N+4 ) holds NDIVS/NIN^2, and +* Z( 2*N+5 ) holds the percentage of shifts that failed. * -* SMALL2 (input) DOUBLE PRECISION -* A threshold value as defined in DLASQ1. -* -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest eigenvalue. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if the i-th argument is a scalar and had an illegal +* value, then INFO = -i, if the i-th argument is an +* array and the j-entry had an illegal value, then +* INFO = -(i*100+j) +* > 0: the algorithm failed +* = 1, a split was marked by a positive value in E +* = 2, current block of Z not diagonalized after 30*N +* iterations (in inner while loop) +* = 3, termination criterion of outer while loop not met +* (program created more than N unreduced blocks) * -* KEND (input/output) INTEGER -* Index where minimum d occurs. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm did not converge; i -* specifies how many superdiagonals did not converge. +* Further Details +* =============== +* Local Variables: I0:N0 defines a current unreduced segment of Z. +* The shifts are accumulated in SIGMA. Iteration count is in ITER. +* Ping-pong is controlled by PP (alternates between 0 and 1). * * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION FOUR, HALF - PARAMETER ( FOUR = 4.0D+0, HALF = 0.5D+0 ) + DOUBLE PRECISION CBIAS + PARAMETER ( CBIAS = 1.50D0 ) + DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, TEN, HNDRD + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0, FOUR = 4.0D0, TEN = 10.0D0, + $ HNDRD = 100.0D0 ) * .. * .. Local Scalars .. - INTEGER ICONV, IPHASE, ISP, N, OFF, OFF1 - DOUBLE PRECISION QEMAX, SIGMA, XINF, XX, YY + INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, + $ N0, NBIG, NDIV, NFAIL, PP, SPLT + DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E, + $ EMAX, EMIN, EPS, EPS2, OLDEMN, QMAX, QMIN, S, + $ SIGMA, T, TAU, TEMP, TRACE, ZMAX * .. * .. External Subroutines .. - EXTERNAL DLASQ3 + EXTERNAL DLASQ3, DLASQ5, DLASRT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, NINT, SQRT + INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. - N = M +* +* Test the input arguments. +* (in case DLASQ2 is not called by DLASQ1) * -* Set the default maximum number of iterations + INFO = 0 + EPS = DLAMCH( 'Precision' )*TEN + EPS2 = EPS**2 * - OFF = 0 - OFF1 = OFF + 1 - SIGMA = ZERO - XINF = ZERO - ICONV = 0 - IPHASE = 2 + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DLASQ2', 1 ) + RETURN + ELSE IF( N.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN * -* Try deflation at the bottom +* 1-by-1 case. +* + IF( Z( 1 ).LT.ZERO ) THEN + INFO = -201 + CALL XERBLA( 'DLASQ2', 2 ) + END IF + RETURN + ELSE IF( N.EQ.2 ) THEN +* +* 2-by-2 case. * -* 1x1 deflation -* - 10 CONTINUE - IF( N.LE.2 ) - $ GO TO 20 - IF( EE( N-1 ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN - Q( N ) = QQ( N ) - N = N - 1 - IF( KEND.GT.N ) - $ KEND = N - SUP = MIN( QQ( N ), QQ( N-1 ) ) - GO TO 10 + IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN + INFO = -2 + CALL XERBLA( 'DLASQ2', 2 ) + RETURN + ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN + D = Z( 3 ) + Z( 3 ) = Z( 1 ) + Z( 1 ) = D + END IF + Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) + IF( Z( 2 ).GT.Z( 3 )*EPS2 ) THEN + T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) + S = Z( 3 )*( Z( 2 ) / T ) + IF( S.LE.T ) THEN + S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) + ELSE + S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) + END IF + T = Z( 1 ) + ( S+Z( 2 ) ) + Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) + Z( 1 ) = T + END IF + Z( 2 ) = Z( 3 ) + Z( 6 ) = Z( 2 ) + Z( 1 ) + Z( 7 ) = ZERO + Z( 8 ) = ZERO + Z( 9 ) = ZERO + RETURN END IF * -* 2x2 deflation +* Check for negative data and compute sums of q's and e's. +* + Z( 2*N ) = ZERO + EMIN = Z( 2 ) + QMAX = ZERO + D = ZERO + E = ZERO +* + DO 10 K = 1, N + IF( Z( K ).LT.ZERO ) THEN + INFO = -( 200+K ) + CALL XERBLA( 'DLASQ2', 2 ) + RETURN + ELSE IF( Z( N+K ).LT.ZERO ) THEN + INFO = -( 200+N+K ) + CALL XERBLA( 'DLASQ2', 2 ) + RETURN + END IF + D = D + Z( K ) + E = E + Z( N+K ) + QMAX = MAX( QMAX, Z( K ) ) + 10 CONTINUE + ZMAX = QMAX + DO 20 K = 1, N - 1 + EMIN = MIN( EMIN, Z( N+K ) ) + ZMAX = MAX( ZMAX, Z( N+K ) ) + 20 CONTINUE +* +* Check for diagonality. * - IF( EE( N-2 ).LE.MAX( XINF, SMALL2, - $ ( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*QQ( N-1 ) )* - $ TOL2 ) THEN - QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1 ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )* - $ MIN( QQ( N ), QQ( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = XX - Q( N ) = YY - N = N - 2 - IF( KEND.GT.N ) - $ KEND = N - SUP = QQ( N ) - GO TO 10 + IF( E.EQ.ZERO ) THEN + CALL DLASRT( 'D', N, Z, IINFO ) + Z( 2*N-1 ) = D + RETURN + END IF +* + TRACE = D + E + I0 = 1 + N0 = N +* +* Check for zero data. +* + IF( TRACE.EQ.ZERO ) THEN + Z( 2*N-1 ) = ZERO + RETURN + END IF +* +* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). +* + DO 30 K = 2*N, 2, -2 + Z( 2*K ) = ZERO + Z( 2*K-1 ) = Z( K ) + Z( 2*K-2 ) = ZERO + Z( 2*K-3 ) = Z( K-1 ) + 30 CONTINUE +* +* Reverse the qd-array, if warranted. +* + IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN + IPN4 = 4*( I0+N0 ) + DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( I4-3 ) + Z( I4-3 ) = Z( IPN4-I4-3 ) + Z( IPN4-I4-3 ) = TEMP + TEMP = Z( I4-1 ) + Z( I4-1 ) = Z( IPN4-I4-5 ) + Z( IPN4-I4-5 ) = TEMP + 40 CONTINUE END IF * - 20 CONTINUE - IF( N.EQ.0 ) THEN +* Initial split checking via dqd and Li's test. +* + PP = 0 * -* The lower branch is finished + DO 80 K = 1, 2 * - IF( OFF.EQ.0 ) THEN + IF( EMIN.LE.EPS2*QMAX ) THEN +* +* Li's reverse test. * -* No upper branch; return to DLASQ1 + D = Z( 4*N0+PP-3 ) + DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 + IF( Z( I4-1 ).LE.EPS2*D ) THEN + Z( I4-1 ) = -ZERO + D = Z( I4-3 ) + ELSE + D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) + END IF + 50 CONTINUE * - RETURN - ELSE -* -* Going back to upper branch +* dqd maps Z to ZZ plus Li's test. * - XINF = ZERO - IF( EE( OFF ).GT.ZERO ) THEN - ISP = NINT( EE( OFF ) ) - IPHASE = 1 - ELSE - ISP = -NINT( EE( OFF ) ) - IPHASE = 2 - END IF - SIGMA = E( OFF ) - N = OFF - ISP + 1 - OFF1 = ISP - OFF = OFF1 - 1 - IF( N.LE.2 ) - $ GO TO 20 - IF( IPHASE.EQ.1 ) THEN - SUP = MIN( Q( N+OFF ), Q( N-1+OFF ), Q( N-2+OFF ) ) - ELSE - SUP = MIN( QQ( N+OFF ), QQ( N-1+OFF ), QQ( N-2+OFF ) ) - END IF - KEND = 0 - ICONV = -3 + EMIN = Z( 4*I0+PP+1 ) + D = Z( 4*I0+PP-3 ) + DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 + IF( Z( I4-1 ).LE.EPS2*D ) THEN + Z( I4-1 ) = -ZERO + Z( I4-2*PP-2 ) = D + Z( I4-2*PP ) = ZERO + D = Z( I4+1 ) + EMIN = ZERO + ELSE + Z( I4-2*PP-2 ) = D + Z( I4-1 ) + Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / + $ Z( I4-2*PP-2 ) ) + D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) + EMIN = MIN( EMIN, Z( I4-2*PP ) ) + END IF + 60 CONTINUE + Z( 4*N0-PP-2 ) = D + ELSE + TAU = ZERO + CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2 ) +* + EMIN = Z( 4*N0 ) END IF - ELSE IF( N.EQ.1 ) THEN +* +* Now find qmax. +* + QMAX = Z( 4*I0-PP-2 ) + DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 + QMAX = MAX( QMAX, Z( I4 ) ) + 70 CONTINUE +* +* Prepare for the next iteration on K. +* + PP = 1 - PP + 80 CONTINUE * -* 1x1 Solver + ITER = 2 + NFAIL = 0 + NDIV = 2*( N0-I0 ) +* + DO 140 IWHILA = 1, N + 1 + IF( N0.LT.1 ) + $ GO TO 150 * - IF( IPHASE.EQ.1 ) THEN - Q( OFF1 ) = Q( OFF1 ) + SIGMA +* While array unfinished do +* +* E(N0) holds the value of SIGMA when submatrix in I0:N0 +* splits from the rest of the array, but is negated. +* + DESIG = ZERO + IF( N0.EQ.N ) THEN + SIGMA = ZERO ELSE - Q( OFF1 ) = QQ( OFF1 ) + SIGMA + SIGMA = -Z( 4*N0-1 ) END IF - N = 0 - GO TO 20 + IF( SIGMA.LT.ZERO ) THEN + INFO = 1 + RETURN + END IF * -* 2x2 Solver +* Find last unreduced submatrix's top index I0, find QMAX and +* EMIN. Find Gershgorin-type bound if Q's much greater than E's. * - ELSE IF( N.EQ.2 ) THEN - IF( IPHASE.EQ.2 ) THEN - QEMAX = MAX( QQ( N+OFF ), QQ( N-1+OFF ), EE( N-1+OFF ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1+OFF ) ) THEN - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*EE( OFF+N-1 ) / - $ QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N+OFF ) ) THEN - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N-1+OFF )-QQ( N+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*EE( N-1+OFF ) / - $ QEMAX ) ) - ELSE - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*QQ( N-1+OFF ) / - $ QEMAX ) ) - END IF - YY = ( MAX( QQ( N+OFF ), QQ( N-1+OFF ) ) / XX )* - $ MIN( QQ( N+OFF ), QQ( N-1+OFF ) ) - ELSE - XX = ZERO - YY = ZERO + EMAX = ZERO + EMIN = ABS( Z( 4*N0-5 ) ) + QMIN = Z( 4*N0-3 ) + QMAX = QMIN + DO 90 I4 = 4*N0, 8, -4 + IF( Z( I4-5 ).LE.ZERO ) + $ GO TO 100 + IF( QMIN.GE.FOUR*EMAX ) THEN + QMIN = MIN( QMIN, Z( I4-3 ) ) + EMAX = MAX( EMAX, Z( I4-5 ) ) END IF - ELSE - QEMAX = MAX( Q( N+OFF ), Q( N-1+OFF ), E( N-1+OFF ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.Q( N-1+OFF ) ) THEN - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) / - $ QEMAX ) ) - ELSE IF( QEMAX.EQ.Q( N+OFF ) ) THEN - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N-1+OFF )-Q( N+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) / - $ QEMAX ) ) - ELSE - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*Q( N-1+OFF ) / - $ QEMAX ) ) + QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) + EMIN = MIN( EMIN, Z( I4-5 ) ) + 90 CONTINUE + I4 = 4 +* + 100 CONTINUE + I0 = I4 / 4 +* +* Store EMIN for passing to DLASQ3. +* + Z( 4*N0-1 ) = EMIN +* +* Put -(initial shift) into DMIN. +* + DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) +* +* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. +* + PP = 0 +* + NBIG = 30*( N0-I0+1 ) + DO 120 IWHILB = 1, NBIG + IF( I0.GT.N0 ) + $ GO TO 130 +* +* While submatrix unfinished take a good dqds step. +* + CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV ) +* + PP = 1 - PP +* +* When EMIN is very small check for splits. +* + IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN + IF( Z( 4*N0 ).LE.EPS2*QMAX .OR. Z( 4*N0-1 ).LE.EPS2* + $ SIGMA ) THEN + SPLT = I0 - 1 + QMAX = Z( 4*I0-3 ) + EMIN = Z( 4*I0-1 ) + OLDEMN = Z( 4*I0 ) + DO 110 I4 = 4*I0, 4*( N0-3 ), 4 + IF( Z( I4 ).LE.EPS2*Z( I4-3 ) .OR. Z( I4-1 ).LE. + $ EPS2*SIGMA ) THEN + Z( I4-1 ) = -SIGMA + SPLT = I4 / 4 + QMAX = ZERO + EMIN = Z( I4+3 ) + OLDEMN = Z( I4+4 ) + ELSE + QMAX = MAX( QMAX, Z( I4+1 ) ) + EMIN = MIN( EMIN, Z( I4-1 ) ) + OLDEMN = MIN( OLDEMN, Z( I4 ) ) + END IF + 110 CONTINUE + Z( 4*N0-1 ) = EMIN + Z( 4*N0 ) = OLDEMN + I0 = SPLT + 1 END IF - YY = ( MAX( Q( N+OFF ), Q( N-1+OFF ) ) / XX )* - $ MIN( Q( N+OFF ), Q( N-1+OFF ) ) - ELSE - XX = ZERO - YY = ZERO END IF - END IF - Q( N-1+OFF ) = SIGMA + XX - Q( N+OFF ) = YY + SIGMA - N = 0 - GO TO 20 - END IF - CALL DLASQ3( N, Q( OFF1 ), E( OFF1 ), QQ( OFF1 ), EE( OFF1 ), SUP, - $ SIGMA, KEND, OFF, IPHASE, ICONV, EPS, TOL2, SMALL2 ) - IF( SUP.LT.ZERO ) THEN - INFO = N + OFF +* + 120 CONTINUE +* + INFO = 2 RETURN - END IF - OFF1 = OFF + 1 - GO TO 20 +* +* end IWHILB +* + 130 CONTINUE +* + 140 CONTINUE +* + INFO = 3 + RETURN +* +* end IWHILA +* + 150 CONTINUE +* +* Move q's to the front. +* + DO 160 K = 2, N + Z( K ) = Z( 4*K-3 ) + 160 CONTINUE +* +* Sort and compute sum of eigenvalues. +* + CALL DLASRT( 'D', N, Z, IINFO ) +* + E = ZERO + DO 170 K = N, 1, -1 + E = E + Z( K ) + 170 CONTINUE +* +* Store trace, sum(eigenvalues) and information on performance. +* + Z( 2*N+1 ) = TRACE + Z( 2*N+2 ) = E + Z( 2*N+3 ) = DBLE( ITER ) + Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) + Z( 2*N+5 ) = HNDRD*NFAIL / DBLE( ITER ) + RETURN * * End of DLASQ2 *
--- a/libcruft/lapack/dlasq3.f +++ b/libcruft/lapack/dlasq3.f @@ -1,819 +1,277 @@ - SUBROUTINE DLASQ3( N, Q, E, QQ, EE, SUP, SIGMA, KEND, OFF, IPHASE, - $ ICONV, EPS, TOL2, SMALL2 ) + SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. - INTEGER ICONV, IPHASE, KEND, N, OFF - DOUBLE PRECISION EPS, SIGMA, SMALL2, SUP, TOL2 + INTEGER I0, ITER, N0, NDIV, NFAIL, PP + DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA * .. * .. Array Arguments .. - DOUBLE PRECISION E( * ), EE( * ), Q( * ), QQ( * ) + DOUBLE PRECISION Z( * ) * .. * -* Purpose -* ======= +* Purpose +* ======= +* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. +* In case of failure it changes shifts, and tries again until output +* is positive. * -* DLASQ3 is the workhorse of the whole bidiagonal SVD algorithm. -* This can be described as the differential qd with shifts. -* -* Arguments -* ========= +* Arguments +* ========= * -* N (input/output) INTEGER -* On entry, N specifies the number of rows and columns -* in the matrix. N must be at least 3. -* On exit N is non-negative and less than the input value. +* I0 (input) INTEGER +* First index. * -* Q (input/output) DOUBLE PRECISION array, dimension (N) -* Q array in ping (see IPHASE below) +* N0 (input) INTEGER +* Last index. * -* E (input/output) DOUBLE PRECISION array, dimension (N) -* E array in ping (see IPHASE below) +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. * -* QQ (input/output) DOUBLE PRECISION array, dimension (N) -* Q array in pong (see IPHASE below) -* -* EE (input/output) DOUBLE PRECISION array, dimension (N) -* E array in pong (see IPHASE below) +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. * -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest eigenvalue +* DMIN (output) DOUBLE PRECISION +* Minimum value of d. * -* SIGMA (input/output) DOUBLE PRECISION -* Accumulated shift for the present submatrix +* SIGMA (output) DOUBLE PRECISION +* Sum of shifts used in current segment. * -* KEND (input/output) INTEGER -* Index where minimum D(i) occurs in recurrence for -* splitting criterion +* DESIG (input/output) DOUBLE PRECISION +* Lower order part of SIGMA * -* OFF (input/output) INTEGER -* Offset for arrays +* QMAX (input) DOUBLE PRECISION +* Maximum value of q. * -* IPHASE (input/output) INTEGER -* If IPHASE = 1 (ping) then data is in Q and E arrays -* If IPHASE = 2 (pong) then data is in QQ and EE arrays +* NFAIL (output) INTEGER +* Number of times shift was too big. * -* ICONV (input) INTEGER -* If ICONV = 0 a bottom part of a matrix (with a split) -* If ICONV =-3 a top part of a matrix (with a split) +* ITER (output) INTEGER +* Number of iterations. * -* EPS (input) DOUBLE PRECISION -* Machine epsilon +* NDIV (output) INTEGER +* Number of divisions. * -* TOL2 (input) DOUBLE PRECISION -* Square of the relative tolerance TOL as defined in DLASQ1 -* -* SMALL2 (input) DOUBLE PRECISION -* A threshold value as defined in DLASQ1 +* TTYPE (output) INTEGER +* Shift type. * * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - INTEGER NPP - PARAMETER ( NPP = 32 ) - INTEGER IPP - PARAMETER ( IPP = 5 ) - DOUBLE PRECISION HALF, FOUR - PARAMETER ( HALF = 0.5D+0, FOUR = 4.0D+0 ) - INTEGER IFLMAX - PARAMETER ( IFLMAX = 2 ) + DOUBLE PRECISION CBIAS + PARAMETER ( CBIAS = 1.50D0 ) + DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, + $ ONE = 1.0D0, TWO = 2.0D0, TEN = 10.0D0 ) * .. * .. Local Scalars .. - LOGICAL LDEF, LSPLIT - INTEGER I, IC, ICNT, IFL, IP, ISP, K1END, K2END, KE, - $ KS, MAXIT, N1, N2 - DOUBLE PRECISION D, DM, QEMAX, T1, TAU, TOLX, TOLY, TOLZ, XX, YY + INTEGER IPN4, J4, N0IN, NN, TTYPE + DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, EPS2, S, + $ SFMIN, T, TAU, TEMP * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLASQ4 + EXTERNAL DLASQ4, DLASQ5, DLASQ6 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. +* .. Save statement .. + SAVE TTYPE, DMIN1, DMIN2, DN, DN1, DN2, TAU +* .. +* .. Data statements .. + DATA TTYPE / 0 / + DATA DMIN1 / ZERO / , DMIN2 / ZERO / , DN / ZERO / , + $ DN1 / ZERO / , DN2 / ZERO / , TAU / ZERO / +* .. * .. Executable Statements .. - ICNT = 0 - TAU = ZERO - DM = SUP - TOLX = SIGMA*TOL2 - TOLZ = MAX( SMALL2, SIGMA )*TOL2 * -* Set maximum number of iterations + N0IN = N0 + EPS = DLAMCH( 'Precision' )*TEN + SFMIN = DLAMCH( 'Safe minimum' ) + EPS2 = EPS**2 * - MAXIT = 100*N +* Check for deflation. * -* Flipping + 10 CONTINUE * - IC = 2 - IF( N.GT.3 ) THEN - IF( IPHASE.EQ.1 ) THEN - DO 10 I = 1, N - 2 - IF( Q( I ).GT.Q( I+1 ) ) - $ IC = IC + 1 - IF( E( I ).GT.E( I+1 ) ) - $ IC = IC + 1 - 10 CONTINUE - IF( Q( N-1 ).GT.Q( N ) ) - $ IC = IC + 1 - IF( IC.LT.N ) THEN - CALL DCOPY( N, Q, 1, QQ, -1 ) - CALL DCOPY( N-1, E, 1, EE, -1 ) - IF( KEND.NE.0 ) - $ KEND = N - KEND + 1 - IPHASE = 2 - END IF - ELSE - DO 20 I = 1, N - 2 - IF( QQ( I ).GT.QQ( I+1 ) ) - $ IC = IC + 1 - IF( EE( I ).GT.EE( I+1 ) ) - $ IC = IC + 1 - 20 CONTINUE - IF( QQ( N-1 ).GT.QQ( N ) ) - $ IC = IC + 1 - IF( IC.LT.N ) THEN - CALL DCOPY( N, QQ, 1, Q, -1 ) - CALL DCOPY( N-1, EE, 1, E, -1 ) - IF( KEND.NE.0 ) - $ KEND = N - KEND + 1 - IPHASE = 1 - END IF - END IF - END IF - IF( ICONV.EQ.-3 ) THEN - IF( IPHASE.EQ.1 ) THEN - GO TO 180 - ELSE - GO TO 80 - END IF - END IF - IF( IPHASE.EQ.2 ) - $ GO TO 130 + 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-by-1 case. * -* The ping section of the code + IF( Z( NN-5 ).GT.EPS2*( SIGMA+Z( NN-3 ) ) .AND. Z( NN-2*PP-4 ).GT. + $ EPS2*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-by-2 case. * 30 CONTINUE - IFL = 0 -* -* Compute the shift -* - IF( KEND.EQ.0 .OR. SUP.EQ.ZERO ) THEN - TAU = ZERO - ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN - TAU = ZERO - ELSE - IP = MAX( IPP, N / NPP ) - N2 = 2*IP + 1 - IF( N2.GE.N ) THEN - N1 = 1 - N2 = N - ELSE IF( KEND+IP.GT.N ) THEN - N1 = N - 2*IP - ELSE IF( KEND-IP.LT.1 ) THEN - N1 = 1 - ELSE - N1 = KEND - IP - END IF - CALL DLASQ4( N2, Q( N1 ), E( N1 ), TAU, SUP ) - END IF - 40 CONTINUE - ICNT = ICNT + 1 - IF( ICNT.GT.MAXIT ) THEN - SUP = -ONE - RETURN - END IF - IF( TAU.EQ.ZERO ) THEN -* -* dqd algorithm * - D = Q( 1 ) - DM = D - KE = 0 - DO 50 I = 1, N - 3 - QQ( I ) = D + E( I ) - D = ( D / QQ( I ) )*Q( I+1 ) - IF( DM.GT.D ) THEN - DM = D - KE = I - END IF - 50 CONTINUE - KE = KE + 1 -* -* Penultimate dqd step (in ping) + IF( Z( NN-9 ).GT.EPS2*SIGMA .AND. Z( NN-2*PP-8 ).GT.EPS2* + $ Z( NN-11 ) )GO TO 50 * - K2END = KE - QQ( N-2 ) = D + E( N-2 ) - D = ( D / QQ( N-2 ) )*Q( N-1 ) - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - END IF -* -* Final dqd step (in ping) -* - K1END = KE - QQ( N-1 ) = D + E( N-1 ) - D = ( D / QQ( N-1 ) )*Q( N ) - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - QQ( N ) = D - ELSE + 40 CONTINUE * -* The dqds algorithm (in ping) -* - D = Q( 1 ) - TAU - DM = D - KE = 0 - IF( D.LT.ZERO ) - $ GO TO 120 - DO 60 I = 1, N - 3 - QQ( I ) = D + E( I ) - D = ( D / QQ( I ) )*Q( I+1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = I - IF( D.LT.ZERO ) - $ GO TO 120 - END IF - 60 CONTINUE - KE = KE + 1 -* -* Penultimate dqds step (in ping) -* - K2END = KE - QQ( N-2 ) = D + E( N-2 ) - D = ( D / QQ( N-2 ) )*Q( N-1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - IF( D.LT.ZERO ) - $ GO TO 120 + 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 )*EPS2 ) 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 -* -* Final dqds step (in ping) + 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 * - K1END = KE - QQ( N-1 ) = D + E( N-1 ) - D = ( D / QQ( N-1 ) )*Q( N ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - QQ( N ) = D - END IF -* -* Convergence when QQ(N) is small (in ping) -* - IF( ABS( QQ( N ) ).LE.SIGMA*TOL2 ) THEN - QQ( N ) = ZERO - DM = ZERO - KE = N - END IF - IF( QQ( N ).LT.ZERO ) - $ GO TO 120 -* -* Non-negative qd array: Update the e's -* - DO 70 I = 1, N - 1 - EE( I ) = ( E( I ) / QQ( I ) )*Q( I+1 ) - 70 CONTINUE -* -* Updating sigma and iphase in ping -* - SIGMA = SIGMA + TAU - IPHASE = 2 - 80 CONTINUE - TOLX = SIGMA*TOL2 - TOLY = SIGMA*EPS - TOLZ = MAX( SIGMA, SMALL2 )*TOL2 -* -* Checking for deflation and convergence (in ping) + 50 CONTINUE * - 90 CONTINUE - IF( N.LE.2 ) - $ RETURN -* -* Deflation: bottom 1x1 (in ping) -* - LDEF = .FALSE. - IF( EE( N-1 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( EE( N-1 ).LE.EPS*( SIGMA+QQ( N ) ) ) THEN - IF( EE( N-1 )*( QQ( N ) / ( QQ( N )+SIGMA ) ).LE.TOL2* - $ ( QQ( N )+SIGMA ) ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( EE( N-1 ).LE.QQ( N )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - Q( N ) = QQ( N ) + SIGMA - N = N - 1 - ICONV = ICONV + 1 - GO TO 90 - END IF -* -* Deflation: bottom 2x2 (in ping) +* Reverse the qd-array, if warranted. * - LDEF = .FALSE. - IF( EE( N-2 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + EE( N-1 )*( SIGMA / ( SIGMA+QQ( N ) ) ) - IF( EE( N-2 )*( T1 / ( QQ( N-1 )+T1 ) ).LE.TOLY ) THEN - IF( EE( N-2 )*( QQ( N-1 ) / ( QQ( N-1 )+T1 ) ).LE.TOLX ) - $ THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( EE( N-2 ).LE.( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )* - $ QQ( N-1 )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1 ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) ) + 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 - YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )* - $ MIN( QQ( N ), QQ( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = SIGMA + XX - Q( N ) = YY + SIGMA - N = N - 2 - ICONV = ICONV + 2 - GO TO 90 - END IF -* -* Updating bounds before going to pong -* - IF( ICONV.EQ.0 ) THEN - KEND = KE - SUP = MIN( DM, SUP-TAU ) - ELSE IF( ICONV.GT.0 ) THEN - SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ), QQ( 1 ), QQ( 2 ), - $ QQ( 3 ) ) - IF( ICONV.EQ.1 ) THEN - KEND = K1END - ELSE IF( ICONV.EQ.2 ) THEN - KEND = K2END - ELSE - KEND = N - END IF - ICNT = 0 - MAXIT = 100*N - END IF -* -* Checking for splitting in ping -* - LSPLIT = .FALSE. - DO 100 KS = N - 3, 3, -1 - IF( EE( KS ).LE.TOLY ) THEN - IF( EE( KS )*( MIN( QQ( KS+1 ), - $ QQ( KS ) ) / ( MIN( QQ( KS+1 ), QQ( KS ) )+SIGMA ) ).LE. - $ TOLX ) THEN - LSPLIT = .TRUE. - GO TO 110 - END IF - END IF - 100 CONTINUE -* - KS = 2 - IF( EE( 2 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + EE( 1 )*( SIGMA / ( SIGMA+QQ( 1 ) ) ) - IF( EE( 2 )*( T1 / ( QQ( 1 )+T1 ) ).LE.TOLY ) THEN - IF( EE( 2 )*( QQ( 1 ) / ( QQ( 1 )+T1 ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( EE( 2 ).LE.( QQ( 1 ) / ( QQ( 1 )+EE( 1 )+QQ( 2 ) ) )* - $ QQ( 2 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF - IF( LSPLIT ) - $ GO TO 110 -* - KS = 1 - IF( EE( 1 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( EE( 1 ).LE.EPS*( SIGMA+QQ( 1 ) ) ) THEN - IF( EE( 1 )*( QQ( 1 ) / ( QQ( 1 )+SIGMA ) ).LE.TOL2* - $ ( QQ( 1 )+SIGMA ) ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( EE( 1 ).LE.QQ( 1 )*TOL2 ) THEN - LSPLIT = .TRUE. + 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*I0-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 * - 110 CONTINUE - IF( LSPLIT ) THEN - SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ) ) - ISP = -( OFF+1 ) - OFF = OFF + KS - N = N - KS - KEND = MAX( 1, KEND-KS ) - E( KS ) = SIGMA - EE( KS ) = ISP - ICONV = 0 - RETURN - END IF + 70 CONTINUE * -* Coincidence -* - IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ. - $ 0 .AND. ICNT.GT.0 ) THEN - CALL DCOPY( N-KE, E( KE ), 1, QQ( KE ), 1 ) - QQ( N ) = ZERO - CALL DCOPY( N-KE, Q( KE+1 ), 1, EE( KE ), 1 ) - SUP = ZERO - END IF - ICONV = 0 - GO TO 130 + IF( DMIN.LT.ZERO .OR. SFMIN*QMAX.LE. + $ MIN( Z( 4*N0+PP-1 ), Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) + $ THEN * -* A new shift when the previous failed (in ping) -* - 120 CONTINUE - IFL = IFL + 1 - SUP = TAU -* -* SUP is small or -* Too many bad shifts (ping) -* - IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN - TAU = ZERO - GO TO 40 +* Choose a shift. * -* The asymptotic shift (in ping) + CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE ) * - ELSE - TAU = MAX( TAU+D, ZERO ) - IF( TAU.LE.TOLZ ) - $ TAU = ZERO - GO TO 40 - END IF -* -* the pong section of the code -* - 130 CONTINUE - IFL = 0 +* Call dqds until DMIN > 0. * -* Compute the shift (in pong) + 80 CONTINUE +* + CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2 ) * - IF( KEND.EQ.0 .AND. SUP.EQ.ZERO ) THEN - TAU = ZERO - ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN - TAU = ZERO - ELSE - IP = MAX( IPP, N / NPP ) - N2 = 2*IP + 1 - IF( N2.GE.N ) THEN - N1 = 1 - N2 = N - ELSE IF( KEND+IP.GT.N ) THEN - N1 = N - 2*IP - ELSE IF( KEND-IP.LT.1 ) THEN - N1 = 1 - ELSE - N1 = KEND - IP - END IF - CALL DLASQ4( N2, QQ( N1 ), EE( N1 ), TAU, SUP ) - END IF - 140 CONTINUE - ICNT = ICNT + 1 - IF( ICNT.GT.MAXIT ) THEN - SUP = -SUP - RETURN - END IF - IF( TAU.EQ.ZERO ) THEN + ITER = ITER + 1 + NDIV = NDIV + ( N0-I0+2 ) +* +* Check for NaN: "DMIN.NE.DMIN" * -* The dqd algorithm (in pong) -* - D = QQ( 1 ) - DM = D - KE = 0 - DO 150 I = 1, N - 3 - Q( I ) = D + EE( I ) - D = ( D / Q( I ) )*QQ( I+1 ) - IF( DM.GT.D ) THEN - DM = D - KE = I - END IF - 150 CONTINUE - KE = KE + 1 -* -* Penultimate dqd step (in pong) -* - K2END = KE - Q( N-2 ) = D + EE( N-2 ) - D = ( D / Q( N-2 ) )*QQ( N-1 ) - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 + IF( DMIN.NE.DMIN ) THEN + Z( 4*N0+PP-1 ) = ZERO + TAU = ZERO + GO TO 70 END IF * -* Final dqd step (in pong) -* - K1END = KE - Q( N-1 ) = D + EE( N-1 ) - D = ( D / Q( N-1 ) )*QQ( N ) - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - Q( N ) = D - ELSE -* -* The dqds algorithm (in pong) +* Check for convergence hidden by negative DN. * - D = QQ( 1 ) - TAU - DM = D - KE = 0 - IF( D.LT.ZERO ) - $ GO TO 220 - DO 160 I = 1, N - 3 - Q( I ) = D + EE( I ) - D = ( D / Q( I ) )*QQ( I+1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = I - IF( D.LT.ZERO ) - $ GO TO 220 - END IF - 160 CONTINUE - KE = KE + 1 -* -* Penultimate dqds step (in pong) -* - K2END = KE - Q( N-2 ) = D + EE( N-2 ) - D = ( D / Q( N-2 ) )*QQ( N-1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - IF( D.LT.ZERO ) - $ GO TO 220 + IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.EPS*( SIGMA+DN1 ) .AND. ABS( DN ).LT. + $ EPS*SIGMA ) THEN + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ABS( DMIN ) END IF * -* Final dqds step (in pong) + IF( DMIN.LT.ZERO ) THEN +* +* Failure. Select new TAU and try again. +* + NFAIL = NFAIL + 1 +* +* Failed twice. Play it safe. +* + IF( TTYPE.LT.-22 ) THEN + TAU = ZERO + GO TO 80 + END IF +* + IF( DMIN1.GT.ZERO ) THEN +* +* Late failure. Gives excellent shift. * - K1END = KE - Q( N-1 ) = D + EE( N-1 ) - D = ( D / Q( N-1 ) )*QQ( N ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N + 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 END IF - Q( N ) = D + ELSE + CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) + ITER = ITER + 1 + NDIV = NDIV + ( N0-I0 ) + TAU = ZERO END IF * -* Convergence when is small (in pong) -* - IF( ABS( Q( N ) ).LE.SIGMA*TOL2 ) THEN - Q( N ) = ZERO - DM = ZERO - KE = N - END IF - IF( Q( N ).LT.ZERO ) - $ GO TO 220 -* -* Non-negative qd array: Update the e's -* - DO 170 I = 1, N - 1 - E( I ) = ( EE( I ) / Q( I ) )*QQ( I+1 ) - 170 CONTINUE -* -* Updating sigma and iphase in pong -* - SIGMA = SIGMA + TAU - 180 CONTINUE - IPHASE = 1 - TOLX = SIGMA*TOL2 - TOLY = SIGMA*EPS -* -* Checking for deflation and convergence (in pong) -* - 190 CONTINUE - IF( N.LE.2 ) - $ RETURN -* -* Deflation: bottom 1x1 (in pong) -* - LDEF = .FALSE. - IF( E( N-1 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( E( N-1 ).LE.EPS*( SIGMA+Q( N ) ) ) THEN - IF( E( N-1 )*( Q( N ) / ( Q( N )+SIGMA ) ).LE.TOL2* - $ ( Q( N )+SIGMA ) ) THEN - LDEF = .TRUE. - END IF - END IF + IF( TAU.LT.SIGMA ) THEN + DESIG = DESIG + TAU + T = SIGMA + DESIG + DESIG = DESIG - ( T-SIGMA ) ELSE - IF( E( N-1 ).LE.Q( N )*TOL2 ) THEN - LDEF = .TRUE. - END IF + T = SIGMA + TAU + DESIG = SIGMA - ( T-TAU ) + DESIG END IF - IF( LDEF ) THEN - Q( N ) = Q( N ) + SIGMA - N = N - 1 - ICONV = ICONV + 1 - GO TO 190 - END IF -* -* Deflation: bottom 2x2 (in pong) -* - LDEF = .FALSE. - IF( E( N-2 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + E( N-1 )*( SIGMA / ( SIGMA+Q( N ) ) ) - IF( E( N-2 )*( T1 / ( Q( N-1 )+T1 ) ).LE.TOLY ) THEN - IF( E( N-2 )*( Q( N-1 ) / ( Q( N-1 )+T1 ) ).LE.TOLX ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( E( N-2 ).LE.( Q( N ) / ( Q( N )+EE( N-1 )+Q( N-1 ) )*Q( N- - $ 1 ) )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - QEMAX = MAX( Q( N ), Q( N-1 ), E( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.Q( N-1 ) ) THEN - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*E( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.Q( N ) ) THEN - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N-1 )-Q( N )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*E( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*Q( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( Q( N ), Q( N-1 ) ) / XX )* - $ MIN( Q( N ), Q( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = SIGMA + XX - Q( N ) = YY + SIGMA - N = N - 2 - ICONV = ICONV + 2 - GO TO 190 - END IF -* -* Updating bounds before going to pong + SIGMA = T * - IF( ICONV.EQ.0 ) THEN - KEND = KE - SUP = MIN( DM, SUP-TAU ) - ELSE IF( ICONV.GT.0 ) THEN - SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ), Q( 1 ), Q( 2 ), Q( 3 ) ) - IF( ICONV.EQ.1 ) THEN - KEND = K1END - ELSE IF( ICONV.EQ.2 ) THEN - KEND = K2END - ELSE - KEND = N - END IF - ICNT = 0 - MAXIT = 100*N - END IF -* -* Checking for splitting in pong -* - LSPLIT = .FALSE. - DO 200 KS = N - 3, 3, -1 - IF( E( KS ).LE.TOLY ) THEN - IF( E( KS )*( MIN( Q( KS+1 ), Q( KS ) ) / ( MIN( Q( KS+1 ), - $ Q( KS ) )+SIGMA ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - GO TO 210 - END IF - END IF - 200 CONTINUE -* - KS = 2 - IF( E( 2 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + E( 1 )*( SIGMA / ( SIGMA+Q( 1 ) ) ) - IF( E( 2 )*( T1 / ( Q( 1 )+T1 ) ).LE.TOLY ) THEN - IF( E( 2 )*( Q( 1 ) / ( Q( 1 )+T1 ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( E( 2 ).LE.( Q( 1 ) / ( Q( 1 )+E( 1 )+Q( 2 ) ) )*Q( 2 )* - $ TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF - IF( LSPLIT ) - $ GO TO 210 -* - KS = 1 - IF( E( 1 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( E( 1 ).LE.EPS*( SIGMA+Q( 1 ) ) ) THEN - IF( E( 1 )*( Q( 1 ) / ( Q( 1 )+SIGMA ) ).LE.TOL2* - $ ( Q( 1 )+SIGMA ) ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( E( 1 ).LE.Q( 1 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF -* - 210 CONTINUE - IF( LSPLIT ) THEN - SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ) ) - ISP = OFF + 1 - OFF = OFF + KS - KEND = MAX( 1, KEND-KS ) - N = N - KS - E( KS ) = SIGMA - EE( KS ) = ISP - ICONV = 0 - RETURN - END IF -* -* Coincidence -* - IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ. - $ 0 .AND. ICNT.GT.0 ) THEN - CALL DCOPY( N-KE, EE( KE ), 1, Q( KE ), 1 ) - Q( N ) = ZERO - CALL DCOPY( N-KE, QQ( KE+1 ), 1, E( KE ), 1 ) - SUP = ZERO - END IF - ICONV = 0 - GO TO 30 -* -* Computation of a new shift when the previous failed (in pong) -* - 220 CONTINUE - IFL = IFL + 1 - SUP = TAU -* -* SUP is small or -* Too many bad shifts (in pong) -* - IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN - TAU = ZERO - GO TO 140 -* -* The asymptotic shift (in pong) -* - ELSE - TAU = MAX( TAU+D, ZERO ) - IF( TAU.LE.TOLZ ) - $ TAU = ZERO - GO TO 140 - END IF + RETURN * * End of DLASQ3 *
--- a/libcruft/lapack/dlasq4.f +++ b/libcruft/lapack/dlasq4.f @@ -1,101 +1,310 @@ - SUBROUTINE DLASQ4( N, Q, E, TAU, SUP ) + SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, TAU, TTYPE ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. - INTEGER N - DOUBLE PRECISION SUP, TAU + INTEGER I0, N0, N0IN, PP, TTYPE + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU * .. * .. Array Arguments .. - DOUBLE PRECISION E( * ), Q( * ) + DOUBLE PRECISION Z( * ) * .. * -* Purpose -* ======= +* Purpose +* ======= +* DLASQ4 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. * -* DLASQ4 estimates TAU, the smallest eigenvalue of a matrix. This -* routine improves the input value of SUP which is an upper bound -* for the smallest eigenvalue for this matrix . +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. +* +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. * -* Arguments -* ========= +* NOIN (input) INTEGER +* The value of N0 at start of EIGTEST. +* +* DMIN (input) DOUBLE PRECISION +* Minimum value of d. * -* N (input) INTEGER -* On entry, N specifies the number of rows and columns -* in the matrix. N must be at least 0. +* 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 ). * -* Q (input) DOUBLE PRECISION array, dimension (N) -* Q array +* DN (input) DOUBLE PRECISION +* d(N) +* +* DN1 (input) DOUBLE PRECISION +* d(N-1) * -* E (input) DOUBLE PRECISION array, dimension (N) -* E array +* DN2 (input) DOUBLE PRECISION +* d(N-2) +* +* TAU (output) DOUBLE PRECISION +* This is the shift. * -* TAU (output) DOUBLE PRECISION -* Estimate of the shift +* TTYPE (output) INTEGER +* Shift type. * -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest singular value +* Further Details +* =============== +* CNST1 = 9/16 * * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION BIS, BIS1 - PARAMETER ( BIS = 0.9999D+0, BIS1 = 0.7D+0 ) - INTEGER IFLMAX - PARAMETER ( IFLMAX = 5 ) + DOUBLE PRECISION CNST1, CNST2, CNST3 + PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, + $ CNST3 = 1.050D0 ) + DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HNDRD + PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, + $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, HNDRD = 100.0D0 ) * .. * .. Local Scalars .. - INTEGER I, IFL - DOUBLE PRECISION D, DM, XINF + INTEGER I4, NN, NP + DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX, MIN, SQRT +* .. +* .. Save statement .. + SAVE G +* .. +* .. Data statements .. + DATA G / ZERO / * .. * .. Executable Statements .. - IFL = 1 - SUP = MIN( SUP, Q( 1 ), Q( 2 ), Q( 3 ), Q( N ), Q( N-1 ), - $ Q( N-2 ) ) - TAU = SUP*BIS - XINF = ZERO - 10 CONTINUE - IF( IFL.EQ.IFLMAX ) THEN - TAU = XINF +* +* 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 - D = Q( 1 ) - TAU - DM = D - DO 20 I = 1, N - 2 - D = ( D / ( D+E( I ) ) )*Q( I+1 ) - TAU - IF( DM.GT.D ) - $ DM = D - IF( D.LT.ZERO ) THEN - SUP = TAU - TAU = MAX( SUP*BIS1**IFL, D+TAU ) - IFL = IFL + 1 - GO TO 10 +* + 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. +* + IF( DMIN.EQ.DN ) THEN + GAM = DN + A2 = ZERO + B2 = Z( NN-5 ) / Z( NN-7 ) + NP = NN - 9 + ELSE + NP = NN - 2*PP + B2 = Z( NP-2 ) + GAM = DN1 + A2 = Z( NP-4 ) / Z( NP-2 ) + B2 = Z( NN-9 ) / Z( NN-11 ) + NP = NN - 13 + END IF +* +* Approximate contribution to norm squared from I < NN-1. +* + IF( B2.EQ.ZERO ) + $ GO TO 20 + A2 = A2 + B2 + DO 10 I4 = NP, 4*I0 - 1 + PP, -4 + B1 = B2 + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HNDRD*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 ) THEN + S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + ELSE + S = QURTR*GAM + END IF + TTYPE = -4 + END IF + ELSE IF( DMIN.EQ.DN2 ) THEN +* +* Case 5. +* +* Compute contribution to norm squared from I > NN-2. +* + NP = NN - 2*PP + B1 = Z( NP-2 ) + B2 = Z( NP-6 ) + GAM = DN2 + 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 ) + IF( B2.EQ.ZERO ) + $ GO TO 40 + A2 = A2 + B2 + DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 + B1 = B2 + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HNDRD*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 ) THEN + S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + ELSE + S = QURTR*GAM / ( ONE+A2 ) + END IF + TTYPE = -5 + 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 - 20 CONTINUE - D = ( D / ( D+E( N-1 ) ) )*Q( N ) - TAU - IF( DM.GT.D ) - $ DM = D - IF( D.LT.ZERO ) THEN - SUP = TAU - XINF = MAX( XINF, D+TAU ) - IF( SUP*BIS1**IFL.LE.XINF ) THEN - TAU = XINF +* + 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. +* + 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 + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HNDRD*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( A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ), + $ THIRD*DMIN1 ) + TTYPE = -7 + ELSE + S = MAX( A2*( ONE-CNST2*B2 ), THIRD*DMIN1 ) + TTYPE = -8 + END IF ELSE - TAU = SUP*BIS1**IFL - IFL = IFL + 1 - GO TO 10 +* +* Case 9. +* + S = QURTR*DMIN1 + IF( DMIN1.EQ.DN1 ) + $ S = HALF*DMIN1 + TTYPE = -9 END IF - ELSE - SUP = MIN( SUP, DM+TAU ) +* + 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 + 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 + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HNDRD*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( A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ), + $ THIRD*DMIN2 ) + ELSE + S = MAX( A2*( ONE-CNST2*B2 ), THIRD*DMIN2 ) + END IF + TTYPE = -10 + 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 DLASQ4
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlasq5.f @@ -0,0 +1,122 @@ + SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, 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 +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER I0, N0, PP + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* Purpose +* ======= +* DLASQ5 computes one dqds transform in ping-pong form. +* +* Arguments +* ========= +* +* I0 (input) INTEGER +* First index. +* +* N0 (input) INTEGER +* Last index. +* +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid +* an extra argument. +* +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. +* +* TAU (input) DOUBLE PRECISION +* This is the shift. +* +* DMIN (output) DOUBLE PRECISION +* Minimum value of d. +* +* DMIN1 (output) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ). +* +* DMIN2 (output) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ) and D( N0-1 ). +* +* DN (output) DOUBLE PRECISION +* d(N0), the last value of d. +* +* DNM1 (output) DOUBLE PRECISION +* d(N0-1). +* +* DNM2 (output) DOUBLE PRECISION +* d(N0-2). +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER J4, J4P2 + DOUBLE PRECISION D, EMIN, TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( ( N0-I0-1 ).LE.0 ) + $ RETURN +* + J4 = 4*I0 + PP - 3 + EMIN = Z( J4+4 ) + D = Z( J4 ) - TAU + DMIN = D +* + IF( PP.EQ.0 ) THEN + DO 10 J4 = 4*I0, 4*( N0-3 ), 4 + Z( J4-2 ) = D + Z( J4-1 ) + TEMP = Z( J4+1 ) / Z( J4-2 ) + D = D*TEMP - TAU + DMIN = MIN( DMIN, D ) + Z( J4 ) = Z( J4-1 )*TEMP + EMIN = MIN( Z( J4 ), EMIN ) + 10 CONTINUE + ELSE + DO 20 J4 = 4*I0, 4*( N0-3 ), 4 + Z( J4-3 ) = D + Z( J4 ) + TEMP = Z( J4+2 ) / Z( J4-3 ) + D = D*TEMP - TAU + DMIN = MIN( DMIN, D ) + Z( J4-1 ) = Z( J4 )*TEMP + EMIN = MIN( Z( J4-1 ), EMIN ) + 20 CONTINUE + END IF +* +* Unroll last two steps. +* + DNM2 = D + DMIN2 = DMIN + J4 = 4*( N0-2 ) - PP + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM2 + Z( J4P2 ) + Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) + DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU + DMIN = MIN( DMIN, DNM1 ) +* + DMIN1 = DMIN + J4 = J4 + 4 + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM1 + Z( J4P2 ) + Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) + DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU + DMIN = MIN( DMIN, DN ) +* + Z( J4+2 ) = DN + Z( 4*N0-PP ) = EMIN + RETURN +* +* End of DLASQ5 +* + END
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/dlasq6.f @@ -0,0 +1,150 @@ + 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 +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER I0, N0, PP + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION Z( * ) +* .. +* +* Purpose +* ======= +* DLASQ6 computes one dqds transform in ping-pong form. +* +* Arguments +* ========= +* +* I0 (input) INTEGER +* First index. +* +* N0 (input) INTEGER +* Last index. +* +* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) +* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid +* an extra argument. +* +* PP (input) INTEGER +* PP=0 for ping, PP=1 for pong. +* +* DMIN (output) DOUBLE PRECISION +* Minimum value of d. +* +* DMIN1 (output) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ). +* +* DMIN2 (output) DOUBLE PRECISION +* Minimum value of d, excluding D( N0 ) and D( N0-1 ). +* +* DN (output) DOUBLE PRECISION +* d(N0), the last value of d. +* +* DNM1 (output) DOUBLE PRECISION +* d(N0-1). +* +* DNM2 (output) DOUBLE PRECISION +* d(N0-2). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER J4, J4P2 + DOUBLE PRECISION D, EMIN, SFMIN, TEMP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( ( N0-I0-1 ).LE.0 ) + $ RETURN +* + SFMIN = DLAMCH( 'Safe minimum' ) + J4 = 4*I0 + PP - 3 + EMIN = Z( J4+4 ) + D = Z( J4 ) + DMIN = D +* + DO 10 J4 = 4*I0 - PP, 4*( N0-3 ) - PP, 4 + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = D + Z( J4P2 ) + IF( Z( J4-2 ).EQ.ZERO ) THEN + Z( J4 ) = ZERO + D = Z( J4P2+2 ) + DMIN = D + EMIN = ZERO + ELSE IF( SFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) ) THEN + TEMP = Z( J4P2+2 ) / Z( J4-2 ) + Z( J4 ) = Z( J4P2 )*TEMP + D = D*TEMP + ELSE + Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) + D = Z( J4P2+2 )*( D / Z( J4-2 ) ) + END IF + DMIN = MIN( DMIN, D ) + EMIN = MIN( EMIN, Z( J4 ) ) + 10 CONTINUE +* +* Unroll last two steps. +* + DNM2 = D + DMIN2 = DMIN + J4 = 4*( N0-2 ) - PP + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM2 + Z( J4P2 ) + IF( Z( J4-2 ).EQ.ZERO ) THEN + Z( J4 ) = ZERO + DNM1 = Z( J4P2+2 ) + DMIN = DNM1 + EMIN = ZERO + ELSE IF( SFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) ) THEN + TEMP = Z( J4P2+2 ) / Z( J4-2 ) + Z( J4 ) = Z( J4P2 )*TEMP + DNM1 = DNM2*TEMP + ELSE + Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) + DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) + END IF + DMIN = MIN( DMIN, DNM1 ) +* + DMIN1 = DMIN + J4 = J4 + 4 + J4P2 = J4 + 2*PP - 1 + Z( J4-2 ) = DNM1 + Z( J4P2 ) + IF( Z( J4-2 ).EQ.ZERO ) THEN + Z( J4 ) = ZERO + DN = Z( J4P2+2 ) + DMIN = DN + EMIN = ZERO + ELSE IF( SFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) ) THEN + TEMP = Z( J4P2+2 ) / Z( J4-2 ) + Z( J4 ) = Z( J4P2 )*TEMP + DN = DNM1*TEMP + ELSE + Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) + DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) + END IF + DMIN = MIN( DMIN, DN ) +* + Z( J4+2 ) = DN + Z( 4*N0-PP ) = EMIN + RETURN +* +* End of DLASQ6 +* + END
--- a/libcruft/lapack/dlasr.f +++ b/libcruft/lapack/dlasr.f @@ -1,6 +1,6 @@ SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlasrt.f +++ b/libcruft/lapack/dlasrt.f @@ -1,6 +1,6 @@ SUBROUTINE DLASRT( ID, N, D, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlassq.f +++ b/libcruft/lapack/dlassq.f @@ -1,9 +1,9 @@ SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N @@ -36,7 +36,7 @@ * N (input) INTEGER * The number of elements to be used from the vector X. * -* X (input) DOUBLE PRECISION +* X (input) DOUBLE PRECISION array, dimension (N) * The vector for which a scaled sum of squares is computed. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. *
--- a/libcruft/lapack/dlasv2.f +++ b/libcruft/lapack/dlasv2.f @@ -1,6 +1,6 @@ SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlaswp.f +++ b/libcruft/lapack/dlaswp.f @@ -1,9 +1,9 @@ SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -50,45 +50,67 @@ * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * +* Further Details +* =============== +* +* Modified by +* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* * ===================================================================== * * .. Local Scalars .. - INTEGER I, IP, IX -* .. -* .. External Subroutines .. - EXTERNAL DSWAP + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * - IF( INCX.EQ.0 ) - $ RETURN IF( INCX.GT.0 ) THEN - IX = K1 + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 ELSE - IX = 1 + ( 1-K2 )*INCX + RETURN END IF - IF( INCX.EQ.1 ) THEN - DO 10 I = K1, K2 - IP = IPIV( I ) - IF( IP.NE.I ) - $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) - 10 CONTINUE - ELSE IF( INCX.GT.1 ) THEN - DO 20 I = K1, K2 +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC IP = IPIV( IX ) - IF( IP.NE.I ) - $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF IX = IX + INCX - 20 CONTINUE - ELSE IF( INCX.LT.0 ) THEN - DO 30 I = K2, K1, -1 - IP = IPIV( IX ) - IF( IP.NE.I ) - $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) - IX = IX + INCX - 30 CONTINUE + 50 CONTINUE END IF * RETURN
--- a/libcruft/lapack/dlasy2.f +++ b/libcruft/lapack/dlasy2.f @@ -1,7 +1,7 @@ SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dlatrd.f +++ b/libcruft/lapack/dlatrd.f @@ -1,6 +1,6 @@ SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dorg2l.f +++ b/libcruft/lapack/dorg2l.f @@ -1,6 +1,6 @@ SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dorg2r.f +++ b/libcruft/lapack/dorg2r.f @@ -1,6 +1,6 @@ SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dorgbr.f +++ b/libcruft/lapack/dorgbr.f @@ -1,16 +1,16 @@ SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER VECT INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -84,6 +84,11 @@ * For optimum performance LWORK >= min(M,N)*NB, 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 @@ -95,12 +100,13 @@ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL WANTQ - INTEGER I, IINFO, J + LOGICAL LQUERY, WANTQ + INTEGER I, IINFO, J, LWKOPT, MN, NB * .. * .. External Functions .. LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORGLQ, DORGQR, XERBLA @@ -114,6 +120,8 @@ * INFO = 0 WANTQ = LSAME( VECT, 'Q' ) + MN = MIN( M, N ) + LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN @@ -126,12 +134,25 @@ INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MIN( M, N ) ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN INFO = -9 END IF +* + IF( INFO.EQ.0 ) THEN + IF( WANTQ ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + ELSE + NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) + END IF + LWKOPT = MAX( 1, MN )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGBR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -216,6 +237,7 @@ END IF END IF END IF + WORK( 1 ) = LWKOPT RETURN * * End of DORGBR
--- a/libcruft/lapack/dorghr.f +++ b/libcruft/lapack/dorghr.f @@ -1,15 +1,15 @@ SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -54,6 +54,11 @@ * For optimum performance LWORK >= (IHI-ILO)*NB, 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 @@ -65,11 +70,16 @@ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, IINFO, J, NH + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL DORGQR, XERBLA * .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. @@ -78,6 +88,8 @@ * Test the input arguments * INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN @@ -86,12 +98,21 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, IHI-ILO ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGHR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -129,7 +150,6 @@ A( J, J ) = ONE 80 CONTINUE * - NH = IHI - ILO IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) @@ -137,6 +157,7 @@ CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF + WORK( 1 ) = LWKOPT RETURN * * End of DORGHR
--- a/libcruft/lapack/dorgl2.f +++ b/libcruft/lapack/dorgl2.f @@ -1,9 +1,9 @@ SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N @@ -121,7 +121,7 @@ END IF A( I, I ) = ONE - TAU( I ) * -* Set A(1:i-1,i) to zero +* Set A(i,1:i-1) to zero * DO 30 L = 1, I - 1 A( I, L ) = ZERO
--- a/libcruft/lapack/dorglq.f +++ b/libcruft/lapack/dorglq.f @@ -1,15 +1,15 @@ SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -57,6 +57,11 @@ * For optimum performance LWORK >= M*NB, 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 has an illegal value @@ -68,8 +73,9 @@ PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA @@ -86,6 +92,10 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, M )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN @@ -94,12 +104,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGLQ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -109,9 +121,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) NBMIN = 2 NX = 0 IWS = M
--- a/libcruft/lapack/dorgql.f +++ b/libcruft/lapack/dorgql.f @@ -1,15 +1,15 @@ SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -58,6 +58,11 @@ * For optimum performance LWORK >= N*NB, 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 has an illegal value @@ -69,8 +74,9 @@ PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, NB, NBMIN, - $ NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, + $ NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA @@ -87,6 +93,10 @@ * 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 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN @@ -95,12 +105,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQL', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -110,9 +122,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) NBMIN = 2 NX = 0 IWS = N
--- a/libcruft/lapack/dorgqr.f +++ b/libcruft/lapack/dorgqr.f @@ -1,15 +1,15 @@ SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -58,6 +58,11 @@ * For optimum performance LWORK >= N*NB, 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 has an illegal value @@ -69,8 +74,9 @@ PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA @@ -87,6 +93,10 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN @@ -95,12 +105,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -110,9 +122,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) NBMIN = 2 NX = 0 IWS = N
--- a/libcruft/lapack/dorgtr.f +++ b/libcruft/lapack/dorgtr.f @@ -1,16 +1,16 @@ SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -56,6 +56,11 @@ * For optimum performance LWORK >= (N-1)*NB, 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 @@ -67,12 +72,13 @@ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IINFO, J + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, J, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORGQL, DORGQR, XERBLA @@ -85,6 +91,7 @@ * Test the input arguments * INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 @@ -92,12 +99,25 @@ INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF +* + IF( INFO.EQ.0 ) THEN + IF( UPPER ) THEN + NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) + ELSE + NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) + END IF + LWKOPT = MAX( 1, N-1 )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGTR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -156,6 +176,7 @@ $ LWORK, IINFO ) END IF END IF + WORK( 1 ) = LWKOPT RETURN * * End of DORGTR
--- a/libcruft/lapack/dorm2r.f +++ b/libcruft/lapack/dorm2r.f @@ -1,7 +1,7 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dormbr.f +++ b/libcruft/lapack/dormbr.f @@ -1,18 +1,17 @@ SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -110,6 +109,11 @@ * 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 @@ -117,13 +121,14 @@ * ===================================================================== * * .. Local Scalars .. - LOGICAL APPLYQ, LEFT, NOTRAN + LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST - INTEGER I1, I2, IINFO, MI, NI, NQ, NW + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORMLQ, DORMQR, XERBLA @@ -139,6 +144,7 @@ APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * @@ -167,12 +173,37 @@ INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF +* + IF( INFO.EQ.0 ) THEN + IF( APPLYQ ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + ELSE + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMBR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -243,6 +274,7 @@ $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF + WORK( 1 ) = LWKOPT RETURN * * End of DORMBR
--- a/libcruft/lapack/dorml2.f +++ b/libcruft/lapack/dorml2.f @@ -1,7 +1,7 @@ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dormlq.f +++ b/libcruft/lapack/dormlq.f @@ -1,18 +1,17 @@ SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -88,6 +87,11 @@ * 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 @@ -99,10 +103,10 @@ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. - LOGICAL LEFT, NOTRAN + LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. DOUBLE PRECISION T( LDT, NBMAX ) @@ -125,6 +129,7 @@ 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 * @@ -149,12 +154,26 @@ INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF +* + IF( INFO.EQ.0 ) THEN +* +* 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, 'DORMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMLQ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -164,11 +183,6 @@ RETURN END IF * -* 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, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN @@ -246,7 +260,7 @@ $ LDWORK ) 10 CONTINUE END IF - WORK( 1 ) = IWS + WORK( 1 ) = LWKOPT RETURN * * End of DORMLQ
--- a/libcruft/lapack/dormqr.f +++ b/libcruft/lapack/dormqr.f @@ -1,18 +1,17 @@ SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -88,6 +87,11 @@ * 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 @@ -99,9 +103,9 @@ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. - LOGICAL LEFT, NOTRAN + LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. DOUBLE PRECISION T( LDT, NBMAX ) @@ -124,6 +128,7 @@ 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 * @@ -148,12 +153,26 @@ INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF +* + IF( INFO.EQ.0 ) THEN +* +* 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, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMQR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -163,11 +182,6 @@ RETURN END IF * -* 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, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN @@ -239,7 +253,7 @@ $ WORK, LDWORK ) 10 CONTINUE END IF - WORK( 1 ) = IWS + WORK( 1 ) = LWKOPT RETURN * * End of DORMQR
--- a/libcruft/lapack/dpotf2.f +++ b/libcruft/lapack/dpotf2.f @@ -1,6 +1,6 @@ SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 1.0) -- +* -- 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
--- a/libcruft/lapack/dpotrf.f +++ b/libcruft/lapack/dpotrf.f @@ -1,9 +1,9 @@ SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 1.0) -- +* -- 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 +* March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO @@ -20,8 +20,8 @@ * positive definite matrix A. * * The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', +* A = U**T * U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', * where U is an upper triangular matrix and L is lower triangular. * * This is the block version of the algorithm, calling Level 3 BLAS. @@ -30,35 +30,33 @@ * ========= * * UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper +* N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower +* leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. +* factorization A = U**T*U or A = L*L**T. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the leading minor of order i is not +* positive definite, and the factorization could not be +* completed. * * ===================================================================== *
--- a/libcruft/lapack/drscl.f +++ b/libcruft/lapack/drscl.f @@ -1,6 +1,6 @@ SUBROUTINE DRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 @@ -53,7 +53,7 @@ EXTERNAL DLAMCH * .. * .. External Subroutines .. - EXTERNAL DLABAD, DSCAL + EXTERNAL DSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS
--- a/libcruft/lapack/dsteqr.f +++ b/libcruft/lapack/dsteqr.f @@ -1,6 +1,6 @@ SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dsterf.f +++ b/libcruft/lapack/dsterf.f @@ -1,9 +1,9 @@ SUBROUTINE DSTERF( N, D, E, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, N @@ -50,11 +50,11 @@ PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. - INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDM1, LENDP1, - $ LENDSV, LM1, LSV, M, MM1, NM1, NMAXIT + INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, + $ NMAXIT DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, - $ SIGMA, SSFMAX, SSFMIN, TST + $ SIGMA, SSFMAX, SSFMIN * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 @@ -102,25 +102,19 @@ * element is smaller. * L1 = 1 - NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 170 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF + DO 20 M = L1, N - 1 + IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE M = N * 30 CONTINUE @@ -169,14 +163,11 @@ * 50 CONTINUE IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 60 M = L, LENDM1 - TST = ABS( E( M ) ) - IF( TST.LE.EPS2*ABS( D( M )*D( M+1 ) ) ) + DO 60 M = L, LEND - 1 + IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) $ GO TO 70 60 CONTINUE END IF -* M = LEND * 70 CONTINUE @@ -219,8 +210,7 @@ * * Inner loop * - MM1 = M - 1 - DO 80 I = MM1, L, -1 + DO 80 I = M - 1, L, -1 BB = E( I ) R = P + BB IF( I.NE.M-1 ) @@ -260,15 +250,10 @@ * Look for small superdiagonal element. * 100 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 110 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) ) - IF( TST.LE.EPS2*ABS( D( M )*D( M-1 ) ) ) - $ GO TO 120 - 110 CONTINUE - END IF -* + DO 110 M = L, LEND + 1, -1 + IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) + $ GO TO 120 + 110 CONTINUE M = LEND * 120 CONTINUE @@ -311,8 +296,7 @@ * * Inner loop * - LM1 = L - 1 - DO 130 I = M, LM1 + DO 130 I = M, L - 1 BB = E( I ) R = P + BB IF( I.NE.M ) @@ -331,7 +315,7 @@ END IF 130 CONTINUE * - E( LM1 ) = S*P + E( L-1 ) = S*P D( L ) = SIGMA + GAMMA GO TO 100 * @@ -360,20 +344,20 @@ * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * - IF( JTOT.EQ.NMAXIT ) THEN - DO 160 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 160 CONTINUE - RETURN - END IF - GO TO 10 + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 160 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 160 CONTINUE + GO TO 180 * * Sort eigenvalues in increasing order. * 170 CONTINUE CALL DLASRT( 'I', N, D, INFO ) * + 180 CONTINUE RETURN * * End of DSTERF
--- a/libcruft/lapack/dsyev.f +++ b/libcruft/lapack/dsyev.f @@ -1,9 +1,9 @@ SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -59,6 +59,11 @@ * For optimal efficiency, LWORK >= (NB+2)*N, * where NB is the blocksize for DSYTRD returned by ILAENV. * +* 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 @@ -73,16 +78,17 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL LOWER, WANTZ + LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LOPT + $ LLWORK, LOPT, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME + INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, @@ -97,6 +103,7 @@ * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN @@ -107,13 +114,21 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) ) THEN + 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 + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYEV ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -189,7 +204,7 @@ * * Set WORK(1) to optimal workspace size. * - WORK( 1 ) = MAX( 3*N-1, LOPT ) + WORK( 1 ) = LWKOPT * RETURN *
--- a/libcruft/lapack/dsytd2.f +++ b/libcruft/lapack/dsytd2.f @@ -1,6 +1,6 @@ SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dsytrd.f +++ b/libcruft/lapack/dsytrd.f @@ -1,9 +1,9 @@ SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO @@ -73,6 +73,11 @@ * For optimum performance LWORK >= N*NB, 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 @@ -124,11 +129,12 @@ * * .. Parameters .. DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) + PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, NB, NBMIN, NX + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA @@ -147,18 +153,31 @@ * INFO = 0 UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.1 ) THEN + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -9 END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -168,9 +187,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) NX = N IWS = 1 IF( NB.GT.1 .AND. NB.LT.N ) THEN @@ -271,7 +287,7 @@ $ TAU( I ), IINFO ) END IF * - WORK( 1 ) = IWS + WORK( 1 ) = LWKOPT RETURN * * End of DSYTRD
--- a/libcruft/lapack/dtgevc.f +++ b/libcruft/lapack/dtgevc.f @@ -1,10 +1,10 @@ SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -112,7 +112,7 @@ * The leading dimension of array VL. * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * -* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) +* 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 * of right Schur vectors returned by DHGEQZ). @@ -235,7 +235,7 @@ EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA + EXTERNAL DGEMV, DLACPY, DLAG2, DLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN @@ -277,6 +277,23 @@ ISIDE = -1 END IF * + INFO = 0 + IF( ISIDE.LT.0 ) THEN + INFO = -1 + ELSE IF( IHWMNY.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGEVC', -INFO ) + RETURN + END IF +* * Count the number of eigenvectors to be computed * IF( .NOT.ILALL ) THEN @@ -318,21 +335,10 @@ END IF 20 CONTINUE * - INFO = 0 - IF( ISIDE.LT.0 ) THEN - INFO = -1 - ELSE IF( IHWMNY.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( ILABAD ) THEN + IF( ILABAD ) THEN INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 ELSE IF( ILBBAD ) THEN INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN INFO = -10 ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
--- a/libcruft/lapack/dtrevc.f +++ b/libcruft/lapack/dtrevc.f @@ -1,10 +1,10 @@ SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -44,7 +44,6 @@ * eigenvectors; only one eigenvector of the pair is computed, namely * the one corresponding to the eigenvalue with positive imaginary part. * -* * Arguments * ========= * @@ -87,6 +86,15 @@ * 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 @@ -107,6 +115,15 @@ * 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 @@ -168,8 +185,7 @@ EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLALN2, DSCAL, - $ XERBLA + EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT @@ -186,7 +202,7 @@ LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) - OVER = LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'O' ) + OVER = LSAME( HOWMNY, 'B' ) SOMEV = LSAME( HOWMNY, 'S' ) * INFO = 0
--- a/libcruft/lapack/dtrexc.f +++ b/libcruft/lapack/dtrexc.f @@ -1,7 +1,7 @@ SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/dtrsen.f +++ b/libcruft/lapack/dtrsen.f @@ -1,10 +1,10 @@ SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -112,7 +112,8 @@ * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) +* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. @@ -120,6 +121,11 @@ * if JOB = 'E', LWORK >= M*(N-M); * if JOB = 'V' or 'B', LWORK >= 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. * @@ -128,6 +134,11 @@ * If JOB = 'N' or 'E', LIWORK >= 1; * if JOB = 'V' or 'B', LIWORK >= M*(N-M). * +* If LIWORK = -1, then a workspace query is assumed; the +* routine only calculates the optimal size of the IWORK array, +* returns this value as the first entry of the IWORK array, and +* no error message related to LIWORK is issued by XERBLA. +* * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value @@ -216,8 +227,10 @@ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL PAIR, SWAP, WANTBH, WANTQ, WANTS, WANTSP - INTEGER IERR, K, KASE, KK, KS, N1, N2, NN + LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS, + $ WANTSP + INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2, + $ NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. External Functions .. @@ -241,6 +254,7 @@ WANTQ = LSAME( COMPQ, 'V' ) * INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 @@ -283,16 +297,34 @@ N2 = N - M NN = N1*N2 * - IF( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND. - $ LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN + IF( WANTSP ) THEN + LWMIN = MAX( 1, 2*NN ) + LIWMIN = MAX( 1, NN ) + ELSE IF( LSAME( JOB, 'N' ) ) THEN + LWMIN = MAX( 1, N ) + LIWMIN = 1 + ELSE IF( LSAME( JOB, 'E' ) ) THEN + LWMIN = MAX( 1, NN ) + LIWMIN = 1 + END IF +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -15 - ELSE IF( LIWORK.LT.1 .OR. ( WANTSP .AND. LIWORK.LT.NN ) ) THEN + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -17 END IF END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSEN', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible. @@ -414,6 +446,10 @@ WI( K+1 ) = -WI( K ) END IF 60 CONTINUE +* + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* RETURN * * End of DTRSEN
--- a/libcruft/lapack/dtrsyl.f +++ b/libcruft/lapack/dtrsyl.f @@ -1,7 +1,7 @@ SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 @@ -111,7 +111,7 @@ EXTERNAL LSAME, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. - EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA + EXTERNAL DLALN2, DLASY2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN
--- a/libcruft/lapack/dzsum1.f +++ b/libcruft/lapack/dzsum1.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
new file mode 100644 --- /dev/null +++ b/libcruft/lapack/ieeeck.f @@ -0,0 +1,148 @@ + 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 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* Purpose +* ======= +* +* IEEECK is called from the ILAENV to verify that Infinity and +* possibly NaN arithmetic is safe (i.e. will not trap). +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies whether to test just for inifinity arithmetic +* or whether to test for infinity and NaN arithmetic. +* = 0: Verify infinity arithmetic only. +* = 1: Verify infinity and NaN arithmetic. +* +* ZERO (input) REAL +* Must contain the value 0.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* ONE (input) REAL +* Must contain the value 1.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* RETURN VALUE: INTEGER +* = 0: Arithmetic failed to produce the correct answers +* = 1: Arithmetic produced the correct answers +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*0.0 +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END
--- a/libcruft/lapack/ilaenv.f +++ b/libcruft/lapack/ilaenv.f @@ -1,10 +1,10 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS @@ -52,6 +52,11 @@ * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. +* = 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 * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or @@ -107,9 +112,14 @@ * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. +* .. External Functions .. + INTEGER IEEECK + EXTERNAL IEEECK +* .. * .. Executable Statements .. * - GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC + GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, + $ 1100 ) ISPEC * * Invalid value for ISPEC * @@ -238,7 +248,7 @@ NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 1 + NB = 32 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF @@ -246,7 +256,7 @@ IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN - NB = 1 + NB = 32 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF @@ -440,11 +450,11 @@ END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 1 + NX = 32 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN - NX = 1 + NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN @@ -501,6 +511,37 @@ ILAENV = 50 RETURN * + 900 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 1000 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +C ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 1100 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +C ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* * End of ILAENV * END
--- a/libcruft/lapack/izmax1.f +++ b/libcruft/lapack/izmax1.f @@ -1,9 +1,9 @@ INTEGER FUNCTION IZMAX1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N @@ -51,7 +51,7 @@ * .. Statement Function definitions .. * * NEXT LINE IS THE ONLY MODIFICATION. - CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + CABS1( ZDUM ) = ABS( ZDUM ) * .. * .. Executable Statements .. *
--- a/libcruft/lapack/zbdsqr.f +++ b/libcruft/lapack/zbdsqr.f @@ -1,10 +1,10 @@ SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO @@ -152,9 +152,9 @@ PARAMETER ( MAXITR = 6 ) * .. * .. Local Scalars .. - LOGICAL ROTATE - INTEGER I, IDIR, IROT, ISUB, ITER, IUPLO, J, LL, LLL, - $ M, MAXIT, NM1, NM12, NM13, OLDLL, OLDM + LOGICAL LOWER, ROTATE + INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, + $ 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, @@ -177,12 +177,8 @@ * Test the input parameters. * INFO = 0 - IUPLO = 0 - IF( LSAME( UPLO, 'U' ) ) - $ IUPLO = 1 - IF( LSAME( UPLO, 'L' ) ) - $ IUPLO = 2 - IF( IUPLO.EQ.0 ) THEN + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 @@ -208,7 +204,7 @@ IF( N.EQ.0 ) $ RETURN IF( N.EQ.1 ) - $ GO TO 150 + $ GO TO 160 * * ROTATE is true if any singular vectors desired, false otherwise * @@ -224,6 +220,7 @@ NM1 = N - 1 NM12 = NM1 + NM1 NM13 = NM12 + NM1 + IDIR = 0 * * Get machine constants * @@ -233,7 +230,7 @@ * If matrix lower bidiagonal, rotate to be upper bidiagonal * by applying Givens rotations on the left * - IF( IUPLO.EQ.2 ) THEN + IF( LOWER ) THEN DO 10 I = 1, N - 1 CALL DLARTG( D( I ), E( I ), CS, SN, R ) D( I ) = R @@ -262,10 +259,13 @@ * * Compute approximate maximum, minimum singular values * - SMAX = ABS( D( N ) ) - DO 20 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) ) + SMAX = ZERO + DO 20 I = 1, N + SMAX = MAX( SMAX, ABS( D( I ) ) ) 20 CONTINUE + DO 30 I = 1, N - 1 + SMAX = MAX( SMAX, ABS( E( I ) ) ) + 30 CONTINUE SMINL = ZERO IF( TOL.GE.ZERO ) THEN * @@ -273,15 +273,15 @@ * SMINOA = ABS( D( 1 ) ) IF( SMINOA.EQ.ZERO ) - $ GO TO 40 + $ GO TO 50 MU = SMINOA - DO 30 I = 2, N + DO 40 I = 2, N MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) SMINOA = MIN( SMINOA, MU ) IF( SMINOA.EQ.ZERO ) - $ GO TO 40 - 30 CONTINUE + $ GO TO 50 40 CONTINUE + 50 CONTINUE SMINOA = SMINOA / SQRT( DBLE( N ) ) THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) ELSE @@ -306,14 +306,14 @@ * * Begin main iteration loop * - 50 CONTINUE + 60 CONTINUE * * Check for convergence or exceeding iteration count * IF( M.LE.1 ) - $ GO TO 150 + $ GO TO 160 IF( ITER.GT.MAXIT ) - $ GO TO 190 + $ GO TO 200 * * Find diagonal block of matrix to work on * @@ -321,20 +321,20 @@ $ D( M ) = ZERO SMAX = ABS( D( M ) ) SMIN = SMAX - DO 60 LLL = 1, M + DO 70 LLL = 1, M - 1 LL = M - LLL - IF( LL.EQ.0 ) - $ GO TO 80 ABSS = ABS( D( LL ) ) ABSE = ABS( E( LL ) ) IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) $ D( LL ) = ZERO IF( ABSE.LE.THRESH ) - $ GO TO 70 + $ GO TO 80 SMIN = MIN( SMIN, ABSS ) SMAX = MAX( SMAX, ABSS, ABSE ) - 60 CONTINUE 70 CONTINUE + LL = 0 + GO TO 90 + 80 CONTINUE E( LL ) = ZERO * * Matrix splits since E(LL) = 0 @@ -344,9 +344,9 @@ * Convergence of bottom singular value, return to top of loop * M = M - 1 - GO TO 50 + GO TO 60 END IF - 80 CONTINUE + 90 CONTINUE LL = LL + 1 * * E(LL) through E(M-1) are nonzero, E(LL-1) is zero @@ -372,7 +372,7 @@ $ CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, $ SINL ) M = M - 2 - GO TO 50 + GO TO 60 END IF * * If working on new submatrix, choose shift direction @@ -402,7 +402,7 @@ IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN E( M-1 ) = ZERO - GO TO 50 + GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN @@ -412,15 +412,15 @@ * MU = ABS( D( LL ) ) SMINL = MU - DO 90 LLL = LL, M - 1 + DO 100 LLL = LL, M - 1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO - GO TO 50 + GO TO 60 END IF SMINLO = SMINL MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) - 90 CONTINUE + 100 CONTINUE END IF * ELSE @@ -431,7 +431,7 @@ IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN E( LL ) = ZERO - GO TO 50 + GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN @@ -441,15 +441,15 @@ * MU = ABS( D( M ) ) SMINL = MU - DO 100 LLL = M - 1, LL, -1 + DO 110 LLL = M - 1, LL, -1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO - GO TO 50 + GO TO 60 END IF SMINLO = SMINL MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) - 100 CONTINUE + 110 CONTINUE END IF END IF OLDLL = LL @@ -498,23 +498,16 @@ * CS = ONE OLDCS = ONE - CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) ) - RWORK( 1 ) = CS - RWORK( 1+NM1 ) = SN - RWORK( 1+NM12 ) = OLDCS - RWORK( 1+NM13 ) = OLDSN - IROT = 1 - DO 110 I = LL + 1, M - 1 + DO 120 I = LL, M - 1 CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - E( I-1 ) = OLDSN*R + IF( I.GT.LL ) + $ E( I-1 ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT + 1 - RWORK( IROT ) = CS - RWORK( IROT+NM1 ) = SN - RWORK( IROT+NM12 ) = OLDCS - RWORK( IROT+NM13 ) = OLDSN - 110 CONTINUE + RWORK( I-LL+1 ) = CS + RWORK( I-LL+1+NM1 ) = SN + RWORK( I-LL+1+NM12 ) = OLDCS + RWORK( I-LL+1+NM13 ) = OLDSN + 120 CONTINUE H = D( M )*CS D( M ) = H*OLDCS E( M-1 ) = H*OLDSN @@ -543,23 +536,16 @@ * CS = ONE OLDCS = ONE - CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) ) - RWORK( M-LL ) = CS - RWORK( M-LL+NM1 ) = -SN - RWORK( M-LL+NM12 ) = OLDCS - RWORK( M-LL+NM13 ) = -OLDSN - IROT = M - LL - DO 120 I = M - 1, LL + 1, -1 + DO 130 I = M, LL + 1, -1 CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - E( I ) = OLDSN*R + IF( I.LT.M ) + $ E( I ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT - 1 - RWORK( IROT ) = CS - RWORK( IROT+NM1 ) = -SN - RWORK( IROT+NM12 ) = OLDCS - RWORK( IROT+NM13 ) = -OLDSN - 120 CONTINUE + RWORK( I-LL ) = CS + RWORK( I-LL+NM1 ) = -SN + RWORK( I-LL+NM12 ) = OLDCS + RWORK( I-LL+NM13 ) = -OLDSN + 130 CONTINUE H = D( LL )*CS D( LL ) = H*OLDCS E( LL ) = H*OLDSN @@ -593,25 +579,10 @@ F = ( ABS( D( LL ) )-SHIFT )* $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) G = E( LL ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( LL ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL ) - G = SINR*D( LL+1 ) - D( LL+1 ) = COSR*D( LL+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL ) = R - F = COSL*E( LL ) + SINL*D( LL+1 ) - D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL ) - G = SINL*E( LL+1 ) - E( LL+1 ) = COSL*E( LL+1 ) - RWORK( 1 ) = COSR - RWORK( 1+NM1 ) = SINR - RWORK( 1+NM12 ) = COSL - RWORK( 1+NM13 ) = SINL - IROT = 1 - DO 130 I = LL + 1, M - 2 + DO 140 I = LL, M - 1 CALL DLARTG( F, G, COSR, SINR, R ) - E( I-1 ) = R + IF( I.GT.LL ) + $ E( I-1 ) = R F = COSR*D( I ) + SINR*E( I ) E( I ) = COSR*E( I ) - SINR*D( I ) G = SINR*D( I+1 ) @@ -620,29 +591,15 @@ D( I ) = R F = COSL*E( I ) + SINL*D( I+1 ) D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - IROT = IROT + 1 - RWORK( IROT ) = COSR - RWORK( IROT+NM1 ) = SINR - RWORK( IROT+NM12 ) = COSL - RWORK( IROT+NM13 ) = SINL - 130 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( M-2 ) = R - F = COSR*D( M-1 ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 ) - G = SINR*D( M ) - D( M ) = COSR*D( M ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M-1 ) = R - F = COSL*E( M-1 ) + SINL*D( M ) - D( M ) = COSL*D( M ) - SINL*E( M-1 ) - IROT = IROT + 1 - RWORK( IROT ) = COSR - RWORK( IROT+NM1 ) = SINR - RWORK( IROT+NM12 ) = COSL - RWORK( IROT+NM13 ) = SINL + IF( I.LT.M-1 ) THEN + G = SINL*E( I+1 ) + E( I+1 ) = COSL*E( I+1 ) + END IF + RWORK( I-LL+1 ) = COSR + RWORK( I-LL+1+NM1 ) = SINR + RWORK( I-LL+1+NM12 ) = COSL + RWORK( I-LL+1+NM13 ) = SINL + 140 CONTINUE E( M-1 ) = F * * Update singular vectors @@ -670,25 +627,10 @@ F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / $ D( M ) ) G = E( M-1 ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( M ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M ) - G = SINR*D( M-1 ) - D( M-1 ) = COSR*D( M-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M ) = R - F = COSL*E( M-1 ) + SINL*D( M-1 ) - D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 ) - G = SINL*E( M-2 ) - E( M-2 ) = COSL*E( M-2 ) - RWORK( M-LL ) = COSR - RWORK( M-LL+NM1 ) = -SINR - RWORK( M-LL+NM12 ) = COSL - RWORK( M-LL+NM13 ) = -SINL - IROT = M - LL - DO 140 I = M - 1, LL + 2, -1 + DO 150 I = M, LL + 1, -1 CALL DLARTG( F, G, COSR, SINR, R ) - E( I ) = R + IF( I.LT.M ) + $ E( I ) = R F = COSR*D( I ) + SINR*E( I-1 ) E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) G = SINR*D( I-1 ) @@ -697,29 +639,15 @@ D( I ) = R F = COSL*E( I-1 ) + SINL*D( I-1 ) D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - IROT = IROT - 1 - RWORK( IROT ) = COSR - RWORK( IROT+NM1 ) = -SINR - RWORK( IROT+NM12 ) = COSL - RWORK( IROT+NM13 ) = -SINL - 140 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( LL+1 ) = R - F = COSR*D( LL+1 ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL+1 ) - G = SINR*D( LL ) - D( LL ) = COSR*D( LL ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL+1 ) = R - F = COSL*E( LL ) + SINL*D( LL ) - D( LL ) = COSL*D( LL ) - SINL*E( LL ) - IROT = IROT - 1 - RWORK( IROT ) = COSR - RWORK( IROT+NM1 ) = -SINR - RWORK( IROT+NM12 ) = COSL - RWORK( IROT+NM13 ) = -SINL + IF( I.GT.LL+1 ) THEN + G = SINL*E( I-2 ) + E( I-2 ) = COSL*E( I-2 ) + END IF + RWORK( I-LL ) = COSR + RWORK( I-LL+NM1 ) = -SINR + RWORK( I-LL+NM12 ) = COSL + RWORK( I-LL+NM13 ) = -SINL + 150 CONTINUE E( LL ) = F * * Test convergence @@ -743,12 +671,12 @@ * * QR iteration finished, go back and check convergence * - GO TO 50 + GO TO 60 * * All singular values converged, so make them positive * - 150 CONTINUE - DO 160 I = 1, N + 160 CONTINUE + DO 170 I = 1, N IF( D( I ).LT.ZERO ) THEN D( I ) = -D( I ) * @@ -757,23 +685,23 @@ IF( NCVT.GT.0 ) $ CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) END IF - 160 CONTINUE + 170 CONTINUE * * Sort the singular values into decreasing order (insertion sort on * singular values, but only one transposition per singular vector) * - DO 180 I = 1, N - 1 + DO 190 I = 1, N - 1 * * Scan for smallest D(I) * ISUB = 1 SMIN = D( 1 ) - DO 170 J = 2, N + 1 - I + DO 180 J = 2, N + 1 - I IF( D( J ).LE.SMIN ) THEN ISUB = J SMIN = D( J ) END IF - 170 CONTINUE + 180 CONTINUE IF( ISUB.NE.N+1-I ) THEN * * Swap singular values and vectors @@ -788,18 +716,18 @@ IF( NCC.GT.0 ) $ CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) END IF - 180 CONTINUE - GO TO 210 + 190 CONTINUE + GO TO 220 * * Maximum number of iterations exceeded, failure to converge * - 190 CONTINUE + 200 CONTINUE INFO = 0 - DO 200 I = 1, N - 1 + DO 210 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 - 200 CONTINUE 210 CONTINUE + 220 CONTINUE RETURN * * End of ZBDSQR
--- a/libcruft/lapack/zdrscl.f +++ b/libcruft/lapack/zdrscl.f @@ -1,6 +1,6 @@ SUBROUTINE ZDRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgebak.f +++ b/libcruft/lapack/zgebak.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgebal.f +++ b/libcruft/lapack/zgebal.f @@ -1,9 +1,9 @@ SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOB @@ -97,13 +97,16 @@ * * This subroutine is based on the EISPACK routine CBAL. * +* Modified by Tzu-Yi Chen, Computer Science Division, University of +* California at Berkeley, USA +* * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) + PARAMETER ( SCLFAC = 0.8D+1 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * ..
--- a/libcruft/lapack/zgebd2.f +++ b/libcruft/lapack/zgebd2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgebrd.f +++ b/libcruft/lapack/zgebrd.f @@ -1,18 +1,17 @@ SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), - $ WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * Purpose @@ -79,6 +78,11 @@ * For optimum performance LWORK >= (M+N)*NB, 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. @@ -137,15 +141,16 @@ PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN, - $ NX + LOGICAL LQUERY + INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, + $ NBMIN, NX DOUBLE PRECISION WS * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC DBLE, MAX, MIN * .. * .. External Functions .. INTEGER ILAENV @@ -156,18 +161,24 @@ * Test the input parameters * INFO = 0 + NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) ) + LWKOPT = ( M+N )*NB + WORK( 1 ) = DBLE( LWKOPT ) + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZGEBRD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -182,15 +193,14 @@ LDWRKX = M LDWRKY = N * -* Set the block size NB and the crossover point NX. + IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * - NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) ) +* Set the crossover point NX. * - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN + NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * - NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) ) IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN
--- a/libcruft/lapack/zgeesx.f +++ b/libcruft/lapack/zgeesx.f @@ -2,10 +2,10 @@ $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -158,8 +158,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DLABAD, DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, - $ ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR + EXTERNAL DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -211,7 +211,7 @@ * in the code.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + 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
--- a/libcruft/lapack/zgeev.f +++ b/libcruft/lapack/zgeev.f @@ -1,10 +1,10 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -85,6 +85,11 @@ * The dimension of the array WORK. LWORK >= max(1,2*N). * For good performance, LWORK must generally be larger. * +* 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. +* * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER @@ -102,7 +107,7 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL SCALEA, WANTVL, WANTVR + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, $ IWRK, K, MAXB, MAXWRK, MINWRK, NOUT @@ -114,8 +119,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, - $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR + EXTERNAL XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, ZHSEQR, + $ ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -131,6 +136,7 @@ * Test the input arguments * INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN @@ -159,7 +165,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + 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 ) @@ -180,12 +186,14 @@ END IF WORK( 1 ) = MAXWRK END IF - IF( LWORK.LT.MINWRK ) THEN + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -12 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEEV ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible
--- a/libcruft/lapack/zgehd2.f +++ b/libcruft/lapack/zgehd2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgehrd.f +++ b/libcruft/lapack/zgehrd.f @@ -1,15 +1,15 @@ SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -56,6 +56,11 @@ * For optimum performance LWORK >= N*NB, 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. @@ -103,7 +108,9 @@ $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, LDWORK, NB, NBMIN, NH, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, + $ NH, NX COMPLEX*16 EI * .. * .. Local Arrays .. @@ -124,6 +131,10 @@ * Test the input parameters * INFO = 0 + NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN @@ -132,12 +143,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEHRD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero @@ -157,9 +170,6 @@ 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
--- a/libcruft/lapack/zgelq2.f +++ b/libcruft/lapack/zgelq2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgelqf.f +++ b/libcruft/lapack/zgelqf.f @@ -1,15 +1,15 @@ SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -50,6 +50,11 @@ * For optimum performance LWORK >= M*NB, 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 @@ -72,7 +77,9 @@ * ===================================================================== * * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT @@ -89,18 +96,24 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) + LWKOPT = M*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELQF', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -111,9 +124,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) NBMIN = 2 NX = 0 IWS = M
--- a/libcruft/lapack/zgelss.f +++ b/libcruft/lapack/zgelss.f @@ -1,10 +1,10 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -87,6 +87,11 @@ * LWORK >= 2*min(M,N) + max(M,N,NRHS) * For good performance, LWORK should generally be larger. * +* 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. +* * RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)-1) * * INFO (output) INTEGER @@ -100,12 +105,13 @@ * * .. Parameters .. DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. + LOGICAL LQUERY INTEGER BL, CHUNK, I, IASCL, IBSCL, IE, IL, IRWORK, $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, $ MAXWRK, MINMN, MINWRK, MM, MNTHR @@ -136,6 +142,7 @@ 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 ELSE IF( N.LT.0 ) THEN @@ -157,7 +164,7 @@ * immediately following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -170,7 +177,7 @@ MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'ZGEQRF', ' ', M, N, $ -1, -1 ) ) MAXWRK = MAX( MAXWRK, N+NRHS* - $ ILAENV( 1, 'ZUNMQR', 'LT', M, NRHS, N, -1 ) ) + $ ILAENV( 1, 'ZUNMQR', 'LC', M, NRHS, N, -1 ) ) END IF IF( M.GE.N ) THEN * @@ -209,7 +216,7 @@ MAXWRK = MAX( MAXWRK, M*M+2*M ) END IF MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'ZUNMLQ', 'LT', N, NRHS, M, -1 ) ) + $ ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M, -1 ) ) ELSE * * Path 2 - underdetermined @@ -219,7 +226,7 @@ MAXWRK = 2*M + ( N+M )*ILAENV( 1, 'ZGEBRD', ' ', M, N, $ -1, -1 ) MAXWRK = MAX( MAXWRK, 2*M+NRHS* - $ ILAENV( 1, 'ZUNMBR', 'QLT', M, NRHS, M, -1 ) ) + $ 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 ) @@ -230,11 +237,13 @@ WORK( 1 ) = MAXWRK END IF * - IF( LWORK.LT.MINWRK ) + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELSS', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -398,9 +407,9 @@ CHUNK = LWORK / N DO 20 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) - CALL ZGEMM( 'C', 'N', N, BL, N, CONE, A, LDA, B, LDB, - $ CZERO, WORK, N ) - CALL ZLACPY( 'G', N, BL, WORK, N, B, LDB ) + CALL ZGEMM( 'C', 'N', N, BL, N, CONE, A, LDA, B( 1, I ), + $ LDB, CZERO, WORK, N ) + CALL ZLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB ) 20 CONTINUE ELSE CALL ZGEMV( 'C', N, N, CONE, A, LDA, B, 1, CZERO, WORK, 1 ) @@ -504,7 +513,8 @@ BL = MIN( NRHS-I+1, CHUNK ) CALL ZGEMM( 'C', 'N', M, BL, M, CONE, WORK( IL ), LDWORK, $ B( 1, I ), LDB, CZERO, WORK( IWORK ), N ) - CALL ZLACPY( 'G', M, BL, WORK( IWORK ), N, B, LDB ) + CALL ZLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + $ LDB ) 40 CONTINUE ELSE CALL ZGEMV( 'C', M, M, CONE, WORK( IL ), LDWORK, B( 1, 1 ),
--- a/libcruft/lapack/zgeqpf.f +++ b/libcruft/lapack/zgeqpf.f @@ -1,9 +1,9 @@ SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -17,6 +17,8 @@ * Purpose * ======= * +* This routine is deprecated and has been replaced by routine ZGEQP3. +* * ZGEQPF computes a QR factorization with column pivoting of a * complex M-by-N matrix A: A*P = Q*R. * @@ -34,7 +36,7 @@ * On exit, the upper triangle of the array contains the * min(M,N)-by-N upper triangular matrix R; the elements * below the diagonal, together with the array TAU, -* represent the orthogonal matrix Q as a product of +* represent the unitary matrix Q as a product of * min(m,n) elementary reflectors. * * LDA (input) INTEGER
--- a/libcruft/lapack/zgeqr2.f +++ b/libcruft/lapack/zgeqr2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgeqrf.f +++ b/libcruft/lapack/zgeqrf.f @@ -1,15 +1,15 @@ SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -51,6 +51,11 @@ * For optimum performance LWORK >= N*NB, 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 @@ -73,7 +78,9 @@ * ===================================================================== * * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, + $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT @@ -90,18 +97,24 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQRF', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -112,9 +125,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) NBMIN = 2 NX = 0 IWS = N
--- a/libcruft/lapack/zgesv.f +++ b/libcruft/lapack/zgesv.f @@ -1,6 +1,6 @@ SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgesvd.f +++ b/libcruft/lapack/zgesvd.f @@ -1,10 +1,10 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -114,6 +114,11 @@ * LWORK >= 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 +* 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. +* * RWORK (workspace) DOUBLE PRECISION array, dimension * (max(3*min(M,N),5*min(M,N)-4)) * On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the @@ -140,8 +145,8 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, WNTVA, - $ WNTVAS, WNTVN, WNTVO, WNTVS + LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, + $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, @@ -184,6 +189,7 @@ WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) MINWRK = 1 + LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 @@ -211,7 +217,8 @@ * 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 .AND. M.GT.0 .AND. N.GT.0 ) THEN + IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. + $ N.GT.0 ) THEN IF( M.GE.N ) THEN * * Space needed for ZBDSQR is BDSPAC = MAX( 3*N, 5*N-4 ) @@ -540,12 +547,14 @@ WORK( 1 ) = MAXWRK END IF * - IF( LWORK.LT.MINWRK ) THEN + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible
--- a/libcruft/lapack/zgetf2.f +++ b/libcruft/lapack/zgetf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgetrf.f +++ b/libcruft/lapack/zgetrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zgetrs.f +++ b/libcruft/lapack/zgetrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zggbal.f +++ b/libcruft/lapack/zggbal.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zheev.f +++ b/libcruft/lapack/zheev.f @@ -1,10 +1,10 @@ SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 2.0) -- +* -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO @@ -61,6 +61,11 @@ * For optimal efficiency, LWORK >= (NB+1)*N, * where NB is the blocksize for ZHETRD returned by ILAENV. * +* 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. +* * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) * * INFO (output) INTEGER @@ -79,16 +84,17 @@ PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. - LOGICAL LOWER, WANTZ + LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LOPT + $ LLWORK, LOPT, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME + INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANHE - EXTERNAL LSAME, DLAMCH, ZLANHE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE * .. * .. External Subroutines .. EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, @@ -103,6 +109,7 @@ * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN @@ -113,13 +120,21 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) ) THEN + 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 + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEEV ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -196,7 +211,7 @@ * * Set WORK(1) to optimal complex workspace size. * - WORK( 1 ) = MAX( 2*N-1, LOPT ) + WORK( 1 ) = LWKOPT * RETURN *
--- a/libcruft/lapack/zhetd2.f +++ b/libcruft/lapack/zhetd2.f @@ -1,6 +1,6 @@ SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zhetrd.f +++ b/libcruft/lapack/zhetrd.f @@ -1,9 +1,9 @@ SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO @@ -73,6 +73,11 @@ * For optimum performance LWORK >= N*NB, 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 @@ -129,8 +134,9 @@ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, NB, NBMIN, NX + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD @@ -149,18 +155,31 @@ * INFO = 0 UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.1 ) THEN + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -9 END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHETRD', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -170,9 +189,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) NX = N IWS = 1 IF( NB.GT.1 .AND. NB.LT.N ) THEN @@ -273,7 +289,7 @@ $ TAU( I ), IINFO ) END IF * - WORK( 1 ) = IWS + WORK( 1 ) = LWKOPT RETURN * * End of ZHETRD
--- a/libcruft/lapack/zhseqr.f +++ b/libcruft/lapack/zhseqr.f @@ -1,10 +1,10 @@ SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPZ, JOB @@ -82,10 +82,16 @@ * The leading dimension of the array Z. * LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. * -* WORK (workspace) COMPLEX*16 array, dimension (N) +* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER -* This argument is currently redundant. +* The dimension of the array WORK. LWORK >= max(1,N). +* +* 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 @@ -108,7 +114,7 @@ PARAMETER ( NSMAX = 15, LDS = NSMAX ) * .. * .. Local Scalars .. - LOGICAL INITZ, WANTT, WANTZ + 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 @@ -125,8 +131,8 @@ EXTERNAL LSAME, ILAENV, IZAMAX, DLAMCH, DLAPY2, ZLANHS * .. * .. External Subroutines .. - EXTERNAL DLABAD, XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLACPY, - $ ZLAHQR, ZLARFG, ZLARFX, ZLASET, ZSCAL + EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLACPY, ZLAHQR, + $ ZLARFG, ZLARFX, ZLASET, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN @@ -146,6 +152,8 @@ WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) * 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 @@ -160,10 +168,14 @@ INFO = -7 ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -12 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHSEQR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Initialize Z, if necessary @@ -454,6 +466,7 @@ GO TO 60 * 180 CONTINUE + WORK( 1 ) = MAX( 1, N ) RETURN * * End of ZHSEQR
--- a/libcruft/lapack/zlabrd.f +++ b/libcruft/lapack/zlabrd.f @@ -1,7 +1,7 @@ SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlacgv.f +++ b/libcruft/lapack/zlacgv.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACGV( N, X, INCX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlacon.f +++ b/libcruft/lapack/zlacon.f @@ -1,9 +1,9 @@ SUBROUTINE ZLACON( N, V, X, EST, KASE ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER KASE, N @@ -55,6 +55,8 @@ * 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 +* * ===================================================================== * * .. Parameters .. @@ -68,7 +70,7 @@ * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP - DOUBLE PRECISION ALTSGN, ESTOLD, SAFMIN, TEMP + DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER IZMAX1 @@ -79,7 +81,7 @@ EXTERNAL ZCOPY * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX + INTRINSIC ABS, DBLE, DCMPLX, DIMAG * .. * .. Save statement .. SAVE @@ -111,8 +113,10 @@ EST = DZSUM1( N, X, 1 ) * DO 30 I = 1, N - IF( ABS( X( I ) ).GT.SAFMIN ) THEN - X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) ) + 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 @@ -152,8 +156,10 @@ $ GO TO 100 * DO 80 I = 1, N - IF( ABS( X( I ) ).GT.SAFMIN ) THEN - X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) ) + 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 @@ -168,7 +174,7 @@ 90 CONTINUE JLAST = J J = IZMAX1( N, X, 1 ) - IF( ( DBLE( X( JLAST ) ).NE.ABS( DBLE( X( J ) ) ) ) .AND. + IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND. $ ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50
--- a/libcruft/lapack/zlacpy.f +++ b/libcruft/lapack/zlacpy.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zladiv.f +++ b/libcruft/lapack/zladiv.f @@ -1,6 +1,6 @@ DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlahqr.f +++ b/libcruft/lapack/zlahqr.f @@ -1,10 +1,10 @@ SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. LOGICAL WANTT, WANTZ @@ -89,14 +89,14 @@ COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION RZERO, RONE, HALF - PARAMETER ( RZERO = 0.0D+0, RONE = 1.0D+0, - $ HALF = 0.5D+0 ) + DOUBLE PRECISION RZERO, HALF + PARAMETER ( RZERO = 0.0D+0, HALF = 0.5D+0 ) + DOUBLE PRECISION DAT1 + PARAMETER ( DAT1 = 0.75D+0 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ - DOUBLE PRECISION H10, H21, OVFL, RTEMP, S, SMLNUM, T2, TST1, - $ ULP, UNFL + DOUBLE PRECISION H10, H21, RTEMP, S, SMLNUM, T2, TST1, ULP COMPLEX*16 CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2, $ X, Y * .. @@ -105,12 +105,12 @@ COMPLEX*16 V( 2 ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, ZLANHS + DOUBLE PRECISION DLAMCH, ZLANHS COMPLEX*16 ZLADIV - EXTERNAL DLAMCH, DLAPY2, ZLANHS, ZLADIV + EXTERNAL DLAMCH, ZLANHS, ZLADIV * .. * .. External Subroutines .. - EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL + EXTERNAL ZCOPY, ZLARFG, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT @@ -140,11 +140,8 @@ * Set machine-dependent constants for the stopping criterion. * If norm(H) <= sqrt(OVFL), overflow should not occur. * - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = RONE / UNFL - CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( NH / ULP ) + SMLNUM = DLAMCH( 'Safe minimum' ) / 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 @@ -213,8 +210,8 @@ * * Exceptional shift. * - T = ABS( DBLE( H( I, I-1 ) ) ) + - $ ABS( DBLE( H( I-1, I-2 ) ) ) + S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) + T = S + H( I, I ) ELSE * * Wilkinson's shift. @@ -232,7 +229,7 @@ * * Look for two consecutive small subdiagonal elements. * - DO 40 M = I - 1, L, -1 + DO 40 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) @@ -247,13 +244,20 @@ H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 - IF( M.EQ.L ) - $ GO TO 50 H10 = H( M, M-1 ) TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) IF( ABS( H10*H21 ).LE.ULP*TST1 ) $ GO TO 50 40 CONTINUE + H11 = H( L, L ) + H22 = H( L+1, L+1 ) + H11S = H11 - T + H21 = H( L+1, L ) + S = CABS1( H11S ) + ABS( H21 ) + H11S = H11S / S + H21 = H21 / S + V( 1 ) = H11S + V( 2 ) = H21 50 CONTINUE * * Single-shift QR step @@ -319,7 +323,7 @@ * real. * TEMP = ONE - T1 - TEMP = TEMP / DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) ) + TEMP = TEMP / ABS( TEMP ) 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 @@ -341,7 +345,7 @@ * TEMP = H( I, I-1 ) IF( DIMAG( TEMP ).NE.RZERO ) THEN - RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) ) + RTEMP = ABS( TEMP ) H( I, I-1 ) = RTEMP TEMP = TEMP / RTEMP IF( I2.GT.I )
--- a/libcruft/lapack/zlahrd.f +++ b/libcruft/lapack/zlahrd.f @@ -1,9 +1,9 @@ SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB @@ -53,7 +53,7 @@ * The scalar factors of the elementary reflectors. See Further * Details. * -* T (output) COMPLEX*16 array, dimension (NB,NB) +* T (output) COMPLEX*16 array, dimension (LDT,NB) * The upper triangular matrix T. * * LDT (input) INTEGER
--- a/libcruft/lapack/zlange.f +++ b/libcruft/lapack/zlange.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlanhe.f +++ b/libcruft/lapack/zlanhe.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlanhs.f +++ b/libcruft/lapack/zlanhs.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlarf.f +++ b/libcruft/lapack/zlarf.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlarfb.f +++ b/libcruft/lapack/zlarfb.f @@ -1,7 +1,7 @@ SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlarfg.f +++ b/libcruft/lapack/zlarfg.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlarft.f +++ b/libcruft/lapack/zlarft.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlarfx.f +++ b/libcruft/lapack/zlarfx.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlartg.f +++ b/libcruft/lapack/zlartg.f @@ -1,9 +1,9 @@ SUBROUTINE ZLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. DOUBLE PRECISION CS @@ -23,8 +23,7 @@ * the following differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. -* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any -* floating point operations. +* If F=0, then CS=0 and SN is chosen so that R is real. * * Arguments * ========= @@ -44,70 +43,147 @@ * R (output) COMPLEX*16 * The nonzero component of the rotated vector. * +* Further Details +* ======= ======= +* +* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel +* * ===================================================================== * * .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + DOUBLE PRECISION TWO, ONE, ZERO + PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - DOUBLE PRECISION D, DI, F1, F2, FA, G1, G2, GA - COMPLEX*16 FS, GS, SS, T + LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, + $ SAFMN2, SAFMX2, SCALE + COMPLEX*16 FF, FS, GS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, DIMAG, SQRT + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, + $ MAX, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1, ABSSQ * .. +* .. Save statement .. + SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. * .. Statement Function definitions .. - ABS1( T ) = ABS( DBLE( T ) ) + ABS( DIMAG( T ) ) - ABSSQ( T ) = DBLE( T )**2 + DIMAG( T )**2 + ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) + ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 * .. * .. Executable Statements .. * -* [ 25 or 38 ops for main paths ] + IF( FIRST ) THEN + FIRST = .FALSE. + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 + END IF + SCALE = MAX( ABS1( F ), ABS1( G ) ) + FS = F + GS = G + COUNT = 0 + IF( SCALE.GE.SAFMX2 ) THEN + 10 CONTINUE + COUNT = COUNT + 1 + FS = FS*SAFMN2 + GS = GS*SAFMN2 + SCALE = SCALE*SAFMN2 + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + ELSE IF( SCALE.LE.SAFMN2 ) THEN + IF( G.EQ.CZERO ) THEN + CS = ONE + SN = CZERO + R = F + RETURN + END IF + 20 CONTINUE + COUNT = COUNT - 1 + FS = FS*SAFMX2 + GS = GS*SAFMX2 + SCALE = SCALE*SAFMX2 + IF( SCALE.LE.SAFMN2 ) + $ GO TO 20 + END IF + F2 = ABSSQ( FS ) + G2 = ABSSQ( GS ) + IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN * - IF( G.EQ.CZERO ) THEN - CS = ONE - SN = ZERO - R = F - ELSE IF( F.EQ.CZERO ) THEN - CS = ZERO +* This is a rare case: F is very small. * - SN = DCONJG( G ) / ABS( G ) - R = ABS( G ) -* -* SN = ONE -* R = G -* + IF( F.EQ.CZERO ) THEN + CS = ZERO + R = DLAPY2( DBLE( G ), DIMAG( G ) ) +* Do complex/real division explicitly with two real divisions + D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) + SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) + RETURN + END IF + F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) +* G2 and G2S are accurate +* G2 is at least SAFMIN, and G2S is at least SAFMN2 + G2S = SQRT( G2 ) +* Error in CS from underflow in F2S is at most +* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS +* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, +* and so CS .lt. sqrt(SAFMIN) +* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN +* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) +* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S + CS = F2S / G2S +* Make sure abs(FF) = 1 +* Do complex/real division explicitly with 2 real divisions + IF( ABS1( F ).GT.ONE ) THEN + D = DLAPY2( DBLE( F ), DIMAG( F ) ) + FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) + ELSE + DR = SAFMX2*DBLE( F ) + DI = SAFMX2*DIMAG( F ) + D = DLAPY2( DR, DI ) + FF = DCMPLX( DR / D, DI / D ) + END IF + SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) + R = CS*F + SN*G ELSE - F1 = ABS1( F ) - G1 = ABS1( G ) - IF( F1.GE.G1 ) THEN - GS = G / F1 - G2 = ABSSQ( GS ) - FS = F / F1 - F2 = ABSSQ( FS ) - D = SQRT( ONE+G2 / F2 ) - CS = ONE / D - SN = DCONJG( GS )*FS*( CS / F2 ) - R = F*D - ELSE - FS = F / G1 - F2 = ABSSQ( FS ) - FA = SQRT( F2 ) - GS = G / G1 - G2 = ABSSQ( GS ) - GA = SQRT( G2 ) - D = SQRT( ONE+F2 / G2 ) - DI = ONE / D - CS = ( FA / GA )*DI - SS = ( DCONJG( GS )*FS ) / ( FA*GA ) - SN = SS*DI - R = G*SS*D +* +* This is the most common case. +* Neither F2 nor F2/G2 are less than SAFMIN +* F2S cannot overflow, and it is accurate +* + F2S = SQRT( ONE+G2 / F2 ) +* Do the F2S(real)*FS(complex) multiply with two real multiplies + R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) + CS = ONE / F2S + D = F2 + G2 +* Do complex/real division explicitly with two real divisions + SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) + SN = SN*DCONJG( GS ) + IF( COUNT.NE.0 ) THEN + IF( COUNT.GT.0 ) THEN + DO 30 I = 1, COUNT + R = R*SAFMX2 + 30 CONTINUE + ELSE + DO 40 I = 1, -COUNT + R = R*SAFMN2 + 40 CONTINUE + END IF END IF END IF RETURN
--- a/libcruft/lapack/zlascl.f +++ b/libcruft/lapack/zlascl.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlaset.f +++ b/libcruft/lapack/zlaset.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlasr.f +++ b/libcruft/lapack/zlasr.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlassq.f +++ b/libcruft/lapack/zlassq.f @@ -1,9 +1,9 @@ SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N @@ -41,7 +41,7 @@ * N (input) INTEGER * The number of elements to be used from the vector X. * -* X (input) DOUBLE PRECISION +* X (input) COMPLEX*16 array, dimension (N) * The vector x as described above. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. *
--- a/libcruft/lapack/zlaswp.f +++ b/libcruft/lapack/zlaswp.f @@ -1,9 +1,9 @@ SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N @@ -50,45 +50,67 @@ * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * +* Further Details +* =============== +* +* Modified by +* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* * ===================================================================== * * .. Local Scalars .. - INTEGER I, IP, IX -* .. -* .. External Subroutines .. - EXTERNAL ZSWAP + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + COMPLEX*16 TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * - IF( INCX.EQ.0 ) - $ RETURN IF( INCX.GT.0 ) THEN - IX = K1 + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 ELSE - IX = 1 + ( 1-K2 )*INCX + RETURN END IF - IF( INCX.EQ.1 ) THEN - DO 10 I = K1, K2 - IP = IPIV( I ) - IF( IP.NE.I ) - $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) - 10 CONTINUE - ELSE IF( INCX.GT.1 ) THEN - DO 20 I = K1, K2 +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC IP = IPIV( IX ) - IF( IP.NE.I ) - $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF IX = IX + INCX - 20 CONTINUE - ELSE IF( INCX.LT.0 ) THEN - DO 30 I = K2, K1, -1 - IP = IPIV( IX ) - IF( IP.NE.I ) - $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) - IX = IX + INCX - 30 CONTINUE + 50 CONTINUE END IF * RETURN
--- a/libcruft/lapack/zlatrd.f +++ b/libcruft/lapack/zlatrd.f @@ -1,6 +1,6 @@ SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zlatrs.f +++ b/libcruft/lapack/zlatrs.f @@ -1,7 +1,7 @@ SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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 @@ -191,7 +191,7 @@ $ ZDOTU, ZLADIV * .. * .. External Subroutines .. - EXTERNAL DLABAD, DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV + EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
--- a/libcruft/lapack/zpotf2.f +++ b/libcruft/lapack/zpotf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zpotrf.f +++ b/libcruft/lapack/zpotrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zrot.f +++ b/libcruft/lapack/zrot.f @@ -1,6 +1,6 @@ SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zsteqr.f +++ b/libcruft/lapack/zsteqr.f @@ -1,6 +1,6 @@ SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/ztrevc.f +++ b/libcruft/lapack/ztrevc.f @@ -1,10 +1,10 @@ SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -76,6 +76,9 @@ * 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 @@ -93,6 +96,9 @@ * 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 @@ -154,7 +160,7 @@ EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM * .. * .. External Subroutines .. - EXTERNAL DLABAD, XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS + EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX @@ -174,7 +180,7 @@ LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) - OVER = LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'O' ) + OVER = LSAME( HOWMNY, 'B' ) SOMEV = LSAME( HOWMNY, 'S' ) * * Set M to the number of columns required to store the selected
--- a/libcruft/lapack/ztrexc.f +++ b/libcruft/lapack/ztrexc.f @@ -1,6 +1,6 @@ SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/ztrsen.f +++ b/libcruft/lapack/ztrsen.f @@ -1,10 +1,10 @@ SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -71,7 +71,7 @@ * The leading dimension of the array Q. * LDQ >= 1; and if COMPQ = 'V', LDQ >= N. * -* W (output) COMPLEX*16 +* W (output) COMPLEX*16 array, dimension (N) * The reordered eigenvalues of T, in the same order as they * appear on the diagonal of T. * @@ -92,8 +92,9 @@ * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * -* WORK (workspace) COMPLEX*16 array, dimension (LWORK) -* If JOB = 'N', WORK 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. * * LWORK (input) INTEGER * The dimension of the array WORK. @@ -101,6 +102,11 @@ * if JOB = 'E', LWORK = M*(N-M); * if JOB = 'V' or 'B', LWORK >= 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. +* * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value @@ -183,8 +189,8 @@ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL WANTBH, WANTQ, WANTS, WANTSP - INTEGER IERR, K, KASE, KS, N1, N2, NN + LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP + INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. Local Arrays .. @@ -223,6 +229,16 @@ NN = N1*N2 * INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) +* + IF( WANTSP ) THEN + LWMIN = MAX( 1, 2*NN ) + ELSE IF( LSAME( JOB, 'N' ) ) THEN + LWMIN = 1 + ELSE IF( LSAME( JOB, 'E' ) ) THEN + LWMIN = MAX( 1, NN ) + END IF +* IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 @@ -234,13 +250,19 @@ INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 - ELSE IF( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND. - $ LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN + ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -14 END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = LWMIN + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRSEN', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -326,6 +348,9 @@ DO 50 K = 1, N W( K ) = T( K, K ) 50 CONTINUE +* + WORK( 1 ) = LWMIN +* RETURN * * End of ZTRSEN
--- a/libcruft/lapack/ztrsyl.f +++ b/libcruft/lapack/ztrsyl.f @@ -1,10 +1,10 @@ SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB @@ -102,11 +102,11 @@ * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE - COMPLEX*16 ZDOTC, ZDOTU - EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU + COMPLEX*16 ZDOTC, ZDOTU, ZLADIV + EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV * .. * .. External Subroutines .. - EXTERNAL DLABAD, XERBLA, ZDSCAL + EXTERNAL XERBLA, ZDSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN @@ -196,7 +196,7 @@ IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF - X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N @@ -244,7 +244,7 @@ $ SCALOC = ONE / DB END IF * - X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N @@ -296,7 +296,7 @@ $ SCALOC = ONE / DB END IF * - X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N @@ -346,7 +346,7 @@ $ SCALOC = ONE / DB END IF * - X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 + X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 ) * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N
--- a/libcruft/lapack/zung2l.f +++ b/libcruft/lapack/zung2l.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zung2r.f +++ b/libcruft/lapack/zung2r.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zungbr.f +++ b/libcruft/lapack/zungbr.f @@ -1,16 +1,16 @@ SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER VECT INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -84,6 +84,11 @@ * For optimum performance LWORK >= min(M,N)*NB, 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 @@ -96,12 +101,13 @@ $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL WANTQ - INTEGER I, IINFO, J + LOGICAL LQUERY, WANTQ + INTEGER I, IINFO, J, LWKOPT, MN, NB * .. * .. External Functions .. LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGLQ, ZUNGQR @@ -115,6 +121,8 @@ * INFO = 0 WANTQ = LSAME( VECT, 'Q' ) + MN = MIN( M, N ) + LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN @@ -127,12 +135,25 @@ INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MIN( M, N ) ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN INFO = -9 END IF +* + IF( INFO.EQ.0 ) THEN + IF( WANTQ ) THEN + NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) + ELSE + NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) + END IF + LWKOPT = MAX( 1, MN )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGBR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -217,6 +238,7 @@ END IF END IF END IF + WORK( 1 ) = LWKOPT RETURN * * End of ZUNGBR
--- a/libcruft/lapack/zunghr.f +++ b/libcruft/lapack/zunghr.f @@ -1,15 +1,15 @@ SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -54,6 +54,11 @@ * For optimum performance LWORK >= (IHI-ILO)*NB, 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 @@ -66,11 +71,16 @@ $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER I, IINFO, J, NH + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGQR * .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. @@ -79,6 +89,8 @@ * Test the input arguments * INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN @@ -87,12 +99,21 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, IHI-ILO ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGHR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -130,7 +151,6 @@ A( J, J ) = ONE 80 CONTINUE * - NH = IHI - ILO IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) @@ -138,6 +158,7 @@ CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF + WORK( 1 ) = LWKOPT RETURN * * End of ZUNGHR
--- a/libcruft/lapack/zungl2.f +++ b/libcruft/lapack/zungl2.f @@ -1,9 +1,9 @@ SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N @@ -124,7 +124,7 @@ END IF A( I, I ) = ONE - DCONJG( TAU( I ) ) * -* Set A(1:i-1,i) to zero +* Set A(i,1:i-1) to zero * DO 30 L = 1, I - 1 A( I, L ) = ZERO
--- a/libcruft/lapack/zunglq.f +++ b/libcruft/lapack/zunglq.f @@ -1,15 +1,15 @@ SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -57,6 +57,11 @@ * For optimum performance LWORK >= M*NB, 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 has an illegal value @@ -68,8 +73,9 @@ PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGL2 @@ -86,6 +92,10 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, M )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN @@ -94,12 +104,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGLQ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -109,9 +121,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) NBMIN = 2 NX = 0 IWS = M
--- a/libcruft/lapack/zungql.f +++ b/libcruft/lapack/zungql.f @@ -1,15 +1,15 @@ SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -58,6 +58,11 @@ * For optimum performance LWORK >= N*NB, 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 has an illegal value @@ -69,8 +74,9 @@ PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, NB, NBMIN, - $ NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, + $ NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L @@ -87,6 +93,10 @@ * 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 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN @@ -95,12 +105,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQL', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -110,9 +122,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) NBMIN = 2 NX = 0 IWS = N
--- a/libcruft/lapack/zungqr.f +++ b/libcruft/lapack/zungqr.f @@ -1,15 +1,15 @@ SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -58,6 +58,11 @@ * For optimum performance LWORK >= N*NB, 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 has an illegal value @@ -69,8 +74,9 @@ PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R @@ -87,6 +93,10 @@ * Test the input arguments * INFO = 0 + NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN @@ -95,12 +105,14 @@ INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -110,9 +122,6 @@ RETURN END IF * -* Determine the block size. -* - NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) NBMIN = 2 NX = 0 IWS = N
--- a/libcruft/lapack/zungtr.f +++ b/libcruft/lapack/zungtr.f @@ -1,16 +1,16 @@ SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -56,6 +56,11 @@ * For optimum performance LWORK >= (N-1)*NB, 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 @@ -68,12 +73,13 @@ $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IINFO, J + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, J, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGQL, ZUNGQR @@ -86,6 +92,7 @@ * Test the input arguments * INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 @@ -93,12 +100,25 @@ INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF +* + IF( INFO.EQ.0 ) THEN + IF( UPPER ) THEN + NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) + ELSE + NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) + END IF + LWKOPT = MAX( 1, N-1 )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGTR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -157,6 +177,7 @@ $ LWORK, IINFO ) END IF END IF + WORK( 1 ) = LWKOPT RETURN * * End of ZUNGTR
--- a/libcruft/lapack/zunm2r.f +++ b/libcruft/lapack/zunm2r.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zunmbr.f +++ b/libcruft/lapack/zunmbr.f @@ -1,18 +1,17 @@ SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -110,6 +109,11 @@ * 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 @@ -117,13 +121,14 @@ * ===================================================================== * * .. Local Scalars .. - LOGICAL APPLYQ, LEFT, NOTRAN + LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST - INTEGER I1, I2, IINFO, MI, NI, NQ, NW + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME - EXTERNAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNMLQ, ZUNMQR @@ -139,6 +144,7 @@ APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * @@ -167,12 +173,36 @@ INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 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 ) + ELSE + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + 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 + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMBR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN END IF * * Quick return if possible @@ -243,6 +273,7 @@ $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF + WORK( 1 ) = LWKOPT RETURN * * End of ZUNMBR
--- a/libcruft/lapack/zunml2.f +++ b/libcruft/lapack/zunml2.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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
--- a/libcruft/lapack/zunmlq.f +++ b/libcruft/lapack/zunmlq.f @@ -1,18 +1,17 @@ SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -88,6 +87,11 @@ * 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 @@ -99,10 +103,10 @@ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. - LOGICAL LEFT, NOTRAN + LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) @@ -125,6 +129,7 @@ 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 * @@ -149,12 +154,26 @@ INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF +* + IF( INFO.EQ.0 ) THEN +* +* 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, 'ZUNMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMLQ', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -164,11 +183,6 @@ RETURN END IF * -* 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, 'ZUNMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN @@ -246,7 +260,7 @@ $ LDWORK ) 10 CONTINUE END IF - WORK( 1 ) = IWS + WORK( 1 ) = LWKOPT RETURN * * End of ZUNMLQ
--- a/libcruft/lapack/zunmqr.f +++ b/libcruft/lapack/zunmqr.f @@ -1,18 +1,17 @@ SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 2.0) -- +* -- 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 +* June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose @@ -88,6 +87,11 @@ * 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 @@ -99,9 +103,9 @@ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. - LOGICAL LEFT, NOTRAN + LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) @@ -124,6 +128,7 @@ 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 * @@ -148,12 +153,26 @@ INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF +* + IF( INFO.EQ.0 ) THEN +* +* 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, 'ZUNMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMQR', -INFO ) RETURN + ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible @@ -163,11 +182,6 @@ RETURN END IF * -* 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, 'ZUNMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN @@ -239,7 +253,7 @@ $ WORK, LDWORK ) 10 CONTINUE END IF - WORK( 1 ) = IWS + WORK( 1 ) = LWKOPT RETURN * * End of ZUNMQR
--- a/liboctave/ChangeLog +++ b/liboctave/ChangeLog @@ -1,3 +1,9 @@ +1999-11-02 John W. Eaton <jwe@bevo.che.wisc.edu> + + * DiagArray2.cc (DiagArray2<T>::operator () (int, int)): + On errors, simply return `T ()'. + (DiagArray2<T>::checkelem (int, int)): Likewise. + 1999-11-02 A. Scottedward Hodel <a.s.hodel@eng.auburn.edu> * dMatrix.cc (Matrix::expm): Do balancing here instead of using
--- a/liboctave/DiagArray2.cc +++ b/liboctave/DiagArray2.cc @@ -89,9 +89,7 @@ if (r < 0 || c < 0 || r >= nr || c >= nc) { (*current_liboctave_error_handler) ("range error"); - T foo; - static T *bar = &foo; - return foo; + return T (); } return (r == c) ? Array<T>::xelem (r) : T (0); } @@ -103,9 +101,7 @@ if (r < 0 || c < 0 || r >= nr || c >= nc) { (*current_liboctave_error_handler) ("range error"); - T foo; - static T *bar = &foo; - return foo; + return T (); } return (r == c) ? Array<T>::xelem (r) : T (0); }
--- a/src/data.cc +++ b/src/data.cc @@ -800,8 +800,7 @@ "-*- texinfo -*-\n\ @deftypefn {Usage} {} is_matrix (@var{a})\n\ Return 1 if @var{a} is a matrix. Otherwise, return 0.\n\ -@end deftypefn\n\ -") +@end deftypefn") { double retval = 0.0;
--- a/src/defaults.cc +++ b/src/defaults.cc @@ -464,6 +464,7 @@ @defvr\n\ The version number of Octave, as a string.\n\ @end defvr"); + } DEFUN (rehash, , ,
--- a/src/help.cc +++ b/src/help.cc @@ -843,8 +843,7 @@ \n\ Once the GNU Info browser is running, help for using it is available\n\ using the command @kbd{C-h}.\n\ -@end deffn\n\ -") +@end deffn") { octave_value_list retval; @@ -1194,8 +1193,7 @@ The variable @code{INFO_FILE} names the location of the Octave info file.\n\ The default value is @code{\"@var{octave-home}/info/octave.info\"}, where\n\ @var{octave-home} is the directory where all of Octave is installed.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (INFO_PROGRAM, Vinfo_prog, info_prog, "-*- texinfo -*-\n\ @@ -1203,8 +1201,7 @@ The variable @code{INFO_FILE} names the location of the Octave info file.\n\ The default value is @code{\"@var{octave-home}/info/octave.info\"}, where\n\ @var{octave-home} is the directory where all of Octave is installed.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (suppress_verbose_help_message, 0.0, suppress_verbose_help_message, "-*- texinfo -*-\n\ @@ -1212,8 +1209,8 @@ If the value of @code{suppress_verbose_help_message} is nonzero, Octave\n\ will not add additional help information to the end of the output from\n\ the @code{help} command and usage messages for built-in commands.\n\ -@end defvr\n\ -"); +@end defvr"); + } /*
--- a/src/input.cc +++ b/src/input.cc @@ -671,8 +671,7 @@ @noindent\n\ If invoked without any arguments, @code{echo} toggles the current echo\n\ state.\n\ -@end deffn\n\ -") +@end deffn") { octave_value_list retval; @@ -747,8 +746,7 @@ might be controlling Octave and handling user input. The current\n\ command number is not incremented when this function is called. This is\n\ a feature, not a bug.\n\ -@end deftypefn\n\ -") +@end deftypefn") { octave_value retval; @@ -923,8 +921,7 @@ @samp{boris} logged in on the host @samp{kremvax.kgb.su}. Note that two\n\ backslashes are required to enter a backslash into a string.\n\ @xref{Strings}.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (PS2, "> ", ps2, "-*- texinfo -*-\n\ @@ -934,18 +931,16 @@ defining a function over several lines, Octave will print the value of\n\ @code{PS1} at the beginning of each line after the first. The default\n\ value of @code{PS2} is @code{\"> \"}.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (PS4, "+ ", ps4, "-*- texinfo -*-\n\ @defvr {Built-in Variable} PS4\n\ If Octave is invoked with the @code{--echo-input} option, the value of\n\ @code{PS4} is printed before each line of input that is echoed. The\n\ -default value of @code{PS4} is @code{"+ "}. @xref{Invoking Octave}, for\n\ +default value of @code{PS4} is @code{\"+ \"}. @xref{Invoking Octave}, for\n\ a description of @code{--echo-input}.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (completion_append_char, " ", completion_append_char, "-*- texinfo -*-\n\ @@ -953,8 +948,7 @@ The value of @code{completion_append_char} is used as the character to\n\ append to successful command-line completion attempts. The default\n\ value is @code{\" \"} (a single space).\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (echo_executing_commands, static_cast<double> (ECHO_OFF), echo_executing_commands, @@ -979,8 +973,8 @@ \n\ The value of @code{echo_executing_commands} is set by the @kbd{echo}\n\ command and the command line option @code{--echo-input}.\n\ -@end defvr\n\ -"); +@end defvr"); + } /*
--- a/src/oct-hist.cc +++ b/src/oct-hist.cc @@ -567,8 +567,7 @@ the first command than the last command reverses the list of commands\n\ before placing them in the buffer to be edited. If both arguments are\n\ omitted, the previous command in the history list is used.\n\ -@end deffn\n\ -") +@end deffn") { octave_value_list retval; @@ -611,8 +610,7 @@ For example, to display the five most recent commands that you have\n\ typed without displaying line numbers, use the command\n\ @kbd{history -q 5}.\n\ -@end deffn\n\ -") +@end deffn") { octave_value_list retval; @@ -633,8 +631,7 @@ @deffn {Command} run_history [first] [last]\n\ Similar to @code{edit_history}, except that the editor is not invoked,\n\ and the commands are simply executed as they appear in the history list.\n\ -@end deffn\n\ -") +@end deffn") { octave_value_list retval; @@ -709,8 +706,7 @@ This variable specifies the name of the file used to store command\n\ history. The default value is @code{\"~/.octave_hist\"}, but may be\n\ overridden by the environment variable @code{OCTAVE_HISTFILE}.\n\ -@end defvr\n\ -"); +@end defvr"); double tmp_hist_size = default_history_size (); @@ -720,8 +716,7 @@ This variable specifies how many entries to store in the history file.\n\ The default value is @code{1024}, but may be overridden by the\n\ environment variable @code{OCTAVE_HISTSIZE}.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (saving_history, 1.0, saving_history, "-*- texinfo -*-\n\ @@ -729,8 +724,8 @@ If the value of @code{saving_history} is nonzero, command entered\n\ on the command line are saved in the file specified by the variable\n\ @code{history_file}.\n\ -@end defvr\n\ -"); +@end defvr"); + } /*
--- a/src/ov.cc +++ b/src/ov.cc @@ -1524,8 +1524,7 @@ If the value of @code{propagate_empty_matrices} is nonzero,\n\ functions like @code{inverse} and @code{svd} will return an empty matrix\n\ if they are given one as an argument. The default value is 1.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (resize_on_range_error, 1.0, resize_on_range_error, "enlarge matrices on assignment");
--- a/src/pager.cc +++ b/src/pager.cc @@ -376,8 +376,7 @@ @end table\n\ \n\ Without any arguments, @code{diary} toggles the current diary state.\n\ -@end deffn\n\ -") +@end deffn") { octave_value_list retval;
--- a/src/pr-output.cc +++ b/src/pr-output.cc @@ -1917,24 +1917,21 @@ @code{fixed_point_format} to a nonzero value.\n\ \n\ The default value of @code{fixed_point_format} is 0.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (output_max_field_width, 10.0, output_max_field_width, "-*- texinfo -*-\n\ @defvr {Built-in Variable} output_max_field_width\n\ This variable specifies the maximum width of a numeric output field.\n\ The default value is 10.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (output_precision, 5.0, output_precision, "-*- texinfo -*-\n\ @defvr {Built-in Variable} output_precision\n\ This variable specifies the minimum number of significant figures to\n\ display for numeric output. The default value is 5.\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (print_empty_dimensions, 1.0, print_empty_dimensions, "-*- texinfo -*-\n\ @@ -1953,8 +1950,7 @@ @example\n\ ans = [](3x0)\n\ @end example\n\ -@end defvr\n\ -"); +@end defvr"); DEFVAR (split_long_rows, 1.0, split_long_rows, "-*- texinfo -*-\n\ @@ -1989,8 +1985,8 @@ \n\ @noindent\n\ The default value of @code{split_long_rows} is nonzero.\n\ -@end defvr\n\ -"); +@end defvr"); + } /*
--- a/src/pt-mat.cc +++ b/src/pt-mat.cc @@ -626,8 +626,8 @@ and the variable @code{a} will be assigned the value @code{[ 1, 3, 5 ]}.\n\ \n\ The default value is @code{\"warn\"}.\n\ -@end defvr\n\ -"); +@end defvr"); + DEFVAR (implicit_num_to_str_ok, 0.0, implicit_num_to_str_ok, "make the result of things like `[97, 98, 99, \"123\"]' be a string");
--- a/src/sysdep.cc +++ b/src/sysdep.cc @@ -120,7 +120,7 @@ { malloc_error (malloc_handler); } -endif +#endif #if defined (__EMX__) OS2_init (void) @@ -324,8 +324,7 @@ @deftypefn {Built-in Function} {} clc ()\n\ @deftypefnx {Built-in Function} {} home ()\n\ Clear the terminal screen and move the cursor to the upper left corner.\n\ -@end deftypefn\n\ -") +@end deftypefn") { command_editor::clear_screen ();
--- a/src/toplev.cc +++ b/src/toplev.cc @@ -242,8 +242,7 @@ Exit the current Octave session. If the optional integer value\n\ @var{status} is supplied, pass that value to the operating system as the\n\ Octave's exit status.\n\ -@end deftypefn\n\ -") +@end deftypefn") { octave_value_list retval; @@ -553,8 +552,7 @@ \n\ @noindent\n\ will print a message when Octave exits.\n\ -@end deftypefn\n\ -") +@end deftypefn") { octave_value_list retval; @@ -723,8 +721,7 @@ \n\ If you write an executable Octave script, @code{argv} will contain the\n\ list of arguments passed to the script. @pxref{Executable Octave Programs}.\n\ -@end defvr\n\ -"); +@end defvr"); DEFCONST (program_invocation_name, octave_env::get_program_invocation_name (), @@ -745,8 +742,7 @@ or using an executable Octave script, the program name is set to the\n\ name of the script. @xref{Executable Octave Programs} for an example of\n\ how to create an executable Octave script.\n\ -@end defvr\n\ -"); +@end defvr"); DEFCONST (program_name, octave_env::get_program_name (), "-*- texinfo -*-\n\ @@ -766,8 +762,8 @@ or using an executable Octave script, the program name is set to the\n\ name of the script. @xref{Executable Octave Programs} for an example of\n\ how to create an executable Octave script.\n\ -@end defvr\n\ -"); +@end defvr"); + } /*