Mercurial > octave-nkf

comparison libcruft/lapack/dtrsen.f @ 7034:68db500cb558

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[project @ 2007-10-16 18:54:19 by jwe]
author jwe
date Tue, 16 Oct 2007 18:54:23 +0000
parents 15cddaacbc2d
children
comparison
equal deleted inserted replaced
7033:f0142f2afdc6 7034:68db500cb558
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 3.0) -- 4 * -- LAPACK routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * Courant Institute, Argonne National Lab, and Rice University 6 * November 2006
7 * June 30, 1999
8 * 7 *
9 * .. Scalar Arguments .. 8 * .. Scalar Arguments ..
10 CHARACTER COMPQ, JOB 9 CHARACTER COMPQ, JOB
11 INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N 10 INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
12 DOUBLE PRECISION S, SEP 11 DOUBLE PRECISION S, SEP
110 * If JOB = 'V' or 'B', SEP is the estimated reciprocal 109 * If JOB = 'V' or 'B', SEP is the estimated reciprocal
111 * condition number of the specified invariant subspace. If 110 * condition number of the specified invariant subspace. If
112 * M = 0 or N, SEP = norm(T). 111 * M = 0 or N, SEP = norm(T).
113 * If JOB = 'N' or 'E', SEP is not referenced. 112 * If JOB = 'N' or 'E', SEP is not referenced.
114 * 113 *
115 * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) 114 * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
116 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 115 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
117 * 116 *
118 * LWORK (input) INTEGER 117 * LWORK (input) INTEGER
119 * The dimension of the array WORK. 118 * The dimension of the array WORK.
120 * If JOB = 'N', LWORK >= max(1,N); 119 * If JOB = 'N', LWORK >= max(1,N);
121 * if JOB = 'E', LWORK >= M*(N-M); 120 * if JOB = 'E', LWORK >= max(1,M*(N-M));
122 * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). 121 * if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
123 * 122 *
124 * If LWORK = -1, then a workspace query is assumed; the routine 123 * If LWORK = -1, then a workspace query is assumed; the routine
125 * only calculates the optimal size of the WORK array, returns 124 * only calculates the optimal size of the WORK array, returns
126 * this value as the first entry of the WORK array, and no error 125 * this value as the first entry of the WORK array, and no error
127 * message related to LWORK is issued by XERBLA. 126 * message related to LWORK is issued by XERBLA.
128 * 127 *
129 * IWORK (workspace) INTEGER array, dimension (LIWORK) 128 * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
130 * IF JOB = 'N' or 'E', IWORK is not referenced. 129 * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
131 * 130 *
132 * LIWORK (input) INTEGER 131 * LIWORK (input) INTEGER
133 * The dimension of the array IWORK. 132 * The dimension of the array IWORK.
134 * If JOB = 'N' or 'E', LIWORK >= 1; 133 * If JOB = 'N' or 'E', LIWORK >= 1;
135 * if JOB = 'V' or 'B', LIWORK >= M*(N-M). 134 * if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
136 * 135 *
137 * If LIWORK = -1, then a workspace query is assumed; the 136 * If LIWORK = -1, then a workspace query is assumed; the
138 * routine only calculates the optimal size of the IWORK array, 137 * routine only calculates the optimal size of the IWORK array,
139 * returns this value as the first entry of the IWORK array, and 138 * returns this value as the first entry of the IWORK array, and
140 * no error message related to LIWORK is issued by XERBLA. 139 * no error message related to LIWORK is issued by XERBLA.
231 $ WANTSP 230 $ WANTSP
232 INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2, 231 INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
233 $ NN 232 $ NN
234 DOUBLE PRECISION EST, RNORM, SCALE 233 DOUBLE PRECISION EST, RNORM, SCALE
235 * .. 234 * ..
235 * .. Local Arrays ..
236 INTEGER ISAVE( 3 )
237 * ..
236 * .. External Functions .. 238 * .. External Functions ..
237 LOGICAL LSAME 239 LOGICAL LSAME
238 DOUBLE PRECISION DLANGE 240 DOUBLE PRECISION DLANGE
239 EXTERNAL LSAME, DLANGE 241 EXTERNAL LSAME, DLANGE
240 * .. 242 * ..
241 * .. External Subroutines .. 243 * .. External Subroutines ..
242 EXTERNAL DLACON, DLACPY, DTREXC, DTRSYL, XERBLA 244 EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA
243 * .. 245 * ..
244 * .. Intrinsic Functions .. 246 * .. Intrinsic Functions ..
245 INTRINSIC ABS, MAX, SQRT 247 INTRINSIC ABS, MAX, SQRT
246 * .. 248 * ..
247 * .. Executable Statements .. 249 * .. Executable Statements ..
406 * Estimate sep(T11,T22). 408 * Estimate sep(T11,T22).
407 * 409 *
408 EST = ZERO 410 EST = ZERO
409 KASE = 0 411 KASE = 0
410 30 CONTINUE 412 30 CONTINUE
411 CALL DLACON( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE ) 413 CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE )
412 IF( KASE.NE.0 ) THEN 414 IF( KASE.NE.0 ) THEN
413 IF( KASE.EQ.1 ) THEN 415 IF( KASE.EQ.1 ) THEN
414 * 416 *
415 * Solve T11*R - R*T22 = scale*X. 417 * Solve T11*R - R*T22 = scale*X.
416 * 418 *