Mercurial > hg > octave-lyh

comparison libcruft/lapack/slanhs.f @ 7789:82be108cc558

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First attempt at single precision tyeps * * * corrections to qrupdate single precision routines * * * prefer demotion to single over promotion to double * * * Add single precision support to log2 function * * * Trivial PROJECT file update * * * Cache optimized hermitian/transpose methods * * * Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author David Bateman <dbateman@free.fr>
date Sun, 27 Apr 2008 22:34:17 +0200
parents
children
comparison
equal deleted inserted replaced
7788:45f5faba05a2 7789:82be108cc558
1 REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK )
2 *
3 * -- LAPACK auxiliary routine (version 3.1) --
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 * November 2006
6 *
7 * .. Scalar Arguments ..
8 CHARACTER NORM
9 INTEGER LDA, N
10 * ..
11 * .. Array Arguments ..
12 REAL A( LDA, * ), WORK( * )
13 * ..
14 *
15 * Purpose
16 * =======
17 *
18 * SLANHS returns the value of the one norm, or the Frobenius norm, or
19 * the infinity norm, or the element of largest absolute value of a
20 * Hessenberg matrix A.
21 *
22 * Description
23 * ===========
24 *
25 * SLANHS returns the value
26 *
27 * SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
28 * (
29 * ( norm1(A), NORM = '1', 'O' or 'o'
30 * (
31 * ( normI(A), NORM = 'I' or 'i'
32 * (
33 * ( normF(A), NORM = 'F', 'f', 'E' or 'e'
34 *
35 * where norm1 denotes the one norm of a matrix (maximum column sum),
36 * normI denotes the infinity norm of a matrix (maximum row sum) and
37 * normF denotes the Frobenius norm of a matrix (square root of sum of
38 * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
39 *
40 * Arguments
41 * =========
42 *
43 * NORM (input) CHARACTER*1
44 * Specifies the value to be returned in SLANHS as described
45 * above.
46 *
47 * N (input) INTEGER
48 * The order of the matrix A. N >= 0. When N = 0, SLANHS is
49 * set to zero.
50 *
51 * A (input) REAL array, dimension (LDA,N)
52 * The n by n upper Hessenberg matrix A; the part of A below the
53 * first sub-diagonal is not referenced.
54 *
55 * LDA (input) INTEGER
56 * The leading dimension of the array A. LDA >= max(N,1).
57 *
58 * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
59 * where LWORK >= N when NORM = 'I'; otherwise, WORK is not
60 * referenced.
61 *
62 * =====================================================================
63 *
64 * .. Parameters ..
65 REAL ONE, ZERO
66 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
67 * ..
68 * .. Local Scalars ..
69 INTEGER I, J
70 REAL SCALE, SUM, VALUE
71 * ..
72 * .. External Subroutines ..
73 EXTERNAL SLASSQ
74 * ..
75 * .. External Functions ..
76 LOGICAL LSAME
77 EXTERNAL LSAME
78 * ..
79 * .. Intrinsic Functions ..
80 INTRINSIC ABS, MAX, MIN, SQRT
81 * ..
82 * .. Executable Statements ..
83 *
84 IF( N.EQ.0 ) THEN
85 VALUE = ZERO
86 ELSE IF( LSAME( NORM, 'M' ) ) THEN
87 *
88 * Find max(abs(A(i,j))).
89 *
90 VALUE = ZERO
91 DO 20 J = 1, N
92 DO 10 I = 1, MIN( N, J+1 )
93 VALUE = MAX( VALUE, ABS( A( I, J ) ) )
94 10 CONTINUE
95 20 CONTINUE
96 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
97 *
98 * Find norm1(A).
99 *
100 VALUE = ZERO
101 DO 40 J = 1, N
102 SUM = ZERO
103 DO 30 I = 1, MIN( N, J+1 )
104 SUM = SUM + ABS( A( I, J ) )
105 30 CONTINUE
106 VALUE = MAX( VALUE, SUM )
107 40 CONTINUE
108 ELSE IF( LSAME( NORM, 'I' ) ) THEN
109 *
110 * Find normI(A).
111 *
112 DO 50 I = 1, N
113 WORK( I ) = ZERO
114 50 CONTINUE
115 DO 70 J = 1, N
116 DO 60 I = 1, MIN( N, J+1 )
117 WORK( I ) = WORK( I ) + ABS( A( I, J ) )
118 60 CONTINUE
119 70 CONTINUE
120 VALUE = ZERO
121 DO 80 I = 1, N
122 VALUE = MAX( VALUE, WORK( I ) )
123 80 CONTINUE
124 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
125 *
126 * Find normF(A).
127 *
128 SCALE = ZERO
129 SUM = ONE
130 DO 90 J = 1, N
131 CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
132 90 CONTINUE
133 VALUE = SCALE*SQRT( SUM )
134 END IF
135 *
136 SLANHS = VALUE
137 RETURN
138 *
139 * End of SLANHS
140 *
141 END