Mercurial > octave-nkf

comparison libcruft/lapack/zlacon.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 ZLACON( N, V, X, EST, KASE ) 1 SUBROUTINE ZLACON( N, V, X, EST, KASE )
2 * 2 *
3 * -- LAPACK auxiliary routine (version 2.0) -- 3 * -- LAPACK auxiliary routine (version 3.0) --
4 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 4 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
5 * Courant Institute, Argonne National Lab, and Rice University 5 * Courant Institute, Argonne National Lab, and Rice University
6 * October 31, 1992 6 * June 30, 1999
7 * 7 *
8 * .. Scalar Arguments .. 8 * .. Scalar Arguments ..
9 INTEGER KASE, N 9 INTEGER KASE, N
10 DOUBLE PRECISION EST 10 DOUBLE PRECISION EST
11 * .. 11 * ..
52 * Originally named CONEST, dated March 16, 1988. 52 * Originally named CONEST, dated March 16, 1988.
53 * 53 *
54 * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of 54 * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
55 * a real or complex matrix, with applications to condition estimation", 55 * a real or complex matrix, with applications to condition estimation",
56 * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. 56 * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
57 *
58 * Last modified: April, 1999
57 * 59 *
58 * ===================================================================== 60 * =====================================================================
59 * 61 *
60 * .. Parameters .. 62 * .. Parameters ..
61 INTEGER ITMAX 63 INTEGER ITMAX
66 PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), 68 PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
67 $ CONE = ( 1.0D0, 0.0D0 ) ) 69 $ CONE = ( 1.0D0, 0.0D0 ) )
68 * .. 70 * ..
69 * .. Local Scalars .. 71 * .. Local Scalars ..
70 INTEGER I, ITER, J, JLAST, JUMP 72 INTEGER I, ITER, J, JLAST, JUMP
71 DOUBLE PRECISION ALTSGN, ESTOLD, SAFMIN, TEMP 73 DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
72 * .. 74 * ..
73 * .. External Functions .. 75 * .. External Functions ..
74 INTEGER IZMAX1 76 INTEGER IZMAX1
75 DOUBLE PRECISION DLAMCH, DZSUM1 77 DOUBLE PRECISION DLAMCH, DZSUM1
76 EXTERNAL IZMAX1, DLAMCH, DZSUM1 78 EXTERNAL IZMAX1, DLAMCH, DZSUM1
77 * .. 79 * ..
78 * .. External Subroutines .. 80 * .. External Subroutines ..
79 EXTERNAL ZCOPY 81 EXTERNAL ZCOPY
80 * .. 82 * ..
81 * .. Intrinsic Functions .. 83 * .. Intrinsic Functions ..
82 INTRINSIC ABS, DBLE, DCMPLX 84 INTRINSIC ABS, DBLE, DCMPLX, DIMAG
83 * .. 85 * ..
84 * .. Save statement .. 86 * .. Save statement ..
85 SAVE 87 SAVE
86 * .. 88 * ..
87 * .. Executable Statements .. 89 * .. Executable Statements ..
109 GO TO 130 111 GO TO 130
110 END IF 112 END IF
111 EST = DZSUM1( N, X, 1 ) 113 EST = DZSUM1( N, X, 1 )
112 * 114 *
113 DO 30 I = 1, N 115 DO 30 I = 1, N
114 IF( ABS( X( I ) ).GT.SAFMIN ) THEN 116 ABSXI = ABS( X( I ) )
115 X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) ) 117 IF( ABSXI.GT.SAFMIN ) THEN
118 X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
119 $ DIMAG( X( I ) ) / ABSXI )
116 ELSE 120 ELSE
117 X( I ) = CONE 121 X( I ) = CONE
118 END IF 122 END IF
119 30 CONTINUE 123 30 CONTINUE
120 KASE = 2 124 KASE = 2
150 * TEST FOR CYCLING. 154 * TEST FOR CYCLING.
151 IF( EST.LE.ESTOLD ) 155 IF( EST.LE.ESTOLD )
152 $ GO TO 100 156 $ GO TO 100
153 * 157 *
154 DO 80 I = 1, N 158 DO 80 I = 1, N
155 IF( ABS( X( I ) ).GT.SAFMIN ) THEN 159 ABSXI = ABS( X( I ) )
156 X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) ) 160 IF( ABSXI.GT.SAFMIN ) THEN
161 X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
162 $ DIMAG( X( I ) ) / ABSXI )
157 ELSE 163 ELSE
158 X( I ) = CONE 164 X( I ) = CONE
159 END IF 165 END IF
160 80 CONTINUE 166 80 CONTINUE
161 KASE = 2 167 KASE = 2
166 * X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. 172 * X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X.
167 * 173 *
168 90 CONTINUE 174 90 CONTINUE
169 JLAST = J 175 JLAST = J
170 J = IZMAX1( N, X, 1 ) 176 J = IZMAX1( N, X, 1 )
171 IF( ( DBLE( X( JLAST ) ).NE.ABS( DBLE( X( J ) ) ) ) .AND. 177 IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND.
172 $ ( ITER.LT.ITMAX ) ) THEN 178 $ ( ITER.LT.ITMAX ) ) THEN
173 ITER = ITER + 1 179 ITER = ITER + 1
174 GO TO 50 180 GO TO 50
175 END IF 181 END IF
176 * 182 *