Mercurial > hg > octave-nkf

comparison libcruft/lapack/dtrsen.f @ 3333:15cddaacbc2d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[project @ 1999-11-03 19:53:59 by jwe]
author jwe
date Wed, 03 Nov 1999 19:54:52 +0000
parents 30c606bec7a8
children 68db500cb558
comparison
equal deleted inserted replaced
3332:7c03933635c6 3333:15cddaacbc2d
1 SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, 1 SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
2 $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) 2 $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
3 * 3 *
4 * -- LAPACK routine (version 2.0) -- 4 * -- LAPACK routine (version 3.0) --
5 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 5 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
6 * Courant Institute, Argonne National Lab, and Rice University 6 * Courant Institute, Argonne National Lab, and Rice University
7 * September 30, 1994 7 * June 30, 1999
8 * 8 *
9 * .. Scalar Arguments .. 9 * .. Scalar Arguments ..
10 CHARACTER COMPQ, JOB 10 CHARACTER COMPQ, JOB
11 INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N 11 INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
12 DOUBLE PRECISION S, SEP 12 DOUBLE PRECISION S, SEP
110 * If JOB = 'V' or 'B', SEP is the estimated reciprocal 110 * If JOB = 'V' or 'B', SEP is the estimated reciprocal
111 * condition number of the specified invariant subspace. If 111 * condition number of the specified invariant subspace. If
112 * M = 0 or N, SEP = norm(T). 112 * M = 0 or N, SEP = norm(T).
113 * If JOB = 'N' or 'E', SEP is not referenced. 113 * If JOB = 'N' or 'E', SEP is not referenced.
114 * 114 *
115 * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) 115 * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
116 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
116 * 117 *
117 * LWORK (input) INTEGER 118 * LWORK (input) INTEGER
118 * The dimension of the array WORK. 119 * The dimension of the array WORK.
119 * If JOB = 'N', LWORK >= max(1,N); 120 * If JOB = 'N', LWORK >= max(1,N);
120 * if JOB = 'E', LWORK >= M*(N-M); 121 * if JOB = 'E', LWORK >= M*(N-M);
121 * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). 122 * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M).
122 * 123 *
124 * If LWORK = -1, then a workspace query is assumed; the routine
125 * only calculates the optimal size of the WORK array, returns
126 * this value as the first entry of the WORK array, and no error
127 * message related to LWORK is issued by XERBLA.
128 *
123 * IWORK (workspace) INTEGER array, dimension (LIWORK) 129 * IWORK (workspace) INTEGER array, dimension (LIWORK)
124 * IF JOB = 'N' or 'E', IWORK is not referenced. 130 * IF JOB = 'N' or 'E', IWORK is not referenced.
125 * 131 *
126 * LIWORK (input) INTEGER 132 * LIWORK (input) INTEGER
127 * The dimension of the array IWORK. 133 * The dimension of the array IWORK.
128 * If JOB = 'N' or 'E', LIWORK >= 1; 134 * If JOB = 'N' or 'E', LIWORK >= 1;
129 * if JOB = 'V' or 'B', LIWORK >= M*(N-M). 135 * if JOB = 'V' or 'B', LIWORK >= M*(N-M).
136 *
137 * If LIWORK = -1, then a workspace query is assumed; the
138 * routine only calculates the optimal size of the IWORK array,
139 * returns this value as the first entry of the IWORK array, and
140 * no error message related to LIWORK is issued by XERBLA.
130 * 141 *
131 * INFO (output) INTEGER 142 * INFO (output) INTEGER
132 * = 0: successful exit 143 * = 0: successful exit
133 * < 0: if INFO = -i, the i-th argument had an illegal value 144 * < 0: if INFO = -i, the i-th argument had an illegal value
134 * = 1: reordering of T failed because some eigenvalues are too 145 * = 1: reordering of T failed because some eigenvalues are too
214 * .. Parameters .. 225 * .. Parameters ..
215 DOUBLE PRECISION ZERO, ONE 226 DOUBLE PRECISION ZERO, ONE
216 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 227 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
217 * .. 228 * ..
218 * .. Local Scalars .. 229 * .. Local Scalars ..
219 LOGICAL PAIR, SWAP, WANTBH, WANTQ, WANTS, WANTSP 230 LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
220 INTEGER IERR, K, KASE, KK, KS, N1, N2, NN 231 $ WANTSP
232 INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
233 $ NN
221 DOUBLE PRECISION EST, RNORM, SCALE 234 DOUBLE PRECISION EST, RNORM, SCALE
222 * .. 235 * ..
223 * .. External Functions .. 236 * .. External Functions ..
224 LOGICAL LSAME 237 LOGICAL LSAME
225 DOUBLE PRECISION DLANGE 238 DOUBLE PRECISION DLANGE
239 WANTS = LSAME( JOB, 'E' ) .OR. WANTBH 252 WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
240 WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH 253 WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
241 WANTQ = LSAME( COMPQ, 'V' ) 254 WANTQ = LSAME( COMPQ, 'V' )
242 * 255 *
243 INFO = 0 256 INFO = 0
257 LQUERY = ( LWORK.EQ.-1 )
244 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) 258 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
245 $ THEN 259 $ THEN
246 INFO = -1 260 INFO = -1
247 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN 261 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
248 INFO = -2 262 INFO = -2
281 * 295 *
282 N1 = M 296 N1 = M
283 N2 = N - M 297 N2 = N - M
284 NN = N1*N2 298 NN = N1*N2
285 * 299 *
286 IF( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND. 300 IF( WANTSP ) THEN
287 $ LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN 301 LWMIN = MAX( 1, 2*NN )
302 LIWMIN = MAX( 1, NN )
303 ELSE IF( LSAME( JOB, 'N' ) ) THEN
304 LWMIN = MAX( 1, N )
305 LIWMIN = 1
306 ELSE IF( LSAME( JOB, 'E' ) ) THEN
307 LWMIN = MAX( 1, NN )
308 LIWMIN = 1
309 END IF
310 *
311 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
288 INFO = -15 312 INFO = -15
289 ELSE IF( LIWORK.LT.1 .OR. ( WANTSP .AND. LIWORK.LT.NN ) ) THEN 313 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
290 INFO = -17 314 INFO = -17
291 END IF 315 END IF
292 END IF 316 END IF
317 *
318 IF( INFO.EQ.0 ) THEN
319 WORK( 1 ) = LWMIN
320 IWORK( 1 ) = LIWMIN
321 END IF
322 *
293 IF( INFO.NE.0 ) THEN 323 IF( INFO.NE.0 ) THEN
294 CALL XERBLA( 'DTRSEN', -INFO ) 324 CALL XERBLA( 'DTRSEN', -INFO )
325 RETURN
326 ELSE IF( LQUERY ) THEN
295 RETURN 327 RETURN
296 END IF 328 END IF
297 * 329 *
298 * Quick return if possible. 330 * Quick return if possible.
299 * 331 *
412 WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* 444 WI( K ) = SQRT( ABS( T( K, K+1 ) ) )*
413 $ SQRT( ABS( T( K+1, K ) ) ) 445 $ SQRT( ABS( T( K+1, K ) ) )
414 WI( K+1 ) = -WI( K ) 446 WI( K+1 ) = -WI( K )
415 END IF 447 END IF
416 60 CONTINUE 448 60 CONTINUE
449 *
450 WORK( 1 ) = LWMIN
451 IWORK( 1 ) = LIWMIN
452 *
417 RETURN 453 RETURN
418 * 454 *
419 * End of DTRSEN 455 * End of DTRSEN
420 * 456 *
421 END 457 END