source: issm/trunk-jpl/externalpackages/petsc-dev/src/externalpackages/fblaslapack-3.1.1/lapack/clanhe.f@ 11896

Last change on this file since 11896 was 11896, checked in by habbalf, 13 years ago

petsc-dev : Petsc development code in external packages. Mercurial updates
File size: 5.9 KB
Line 
1 REAL FUNCTION CLANHE( NORM, UPLO, 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, UPLO
9 INTEGER LDA, N
10* ..
11* .. Array Arguments ..
12 REAL WORK( * )
13 COMPLEX A( LDA, * )
14* ..
15*
16* Purpose
17* =======
18*
19* CLANHE returns the value of the one norm, or the Frobenius norm, or
20* the infinity norm, or the element of largest absolute value of a
21* complex hermitian matrix A.
22*
23* Description
24* ===========
25*
26* CLANHE returns the value
27*
28* CLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
29* (
30* ( norm1(A), NORM = '1', 'O' or 'o'
31* (
32* ( normI(A), NORM = 'I' or 'i'
33* (
34* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
35*
36* where norm1 denotes the one norm of a matrix (maximum column sum),
37* normI denotes the infinity norm of a matrix (maximum row sum) and
38* normF denotes the Frobenius norm of a matrix (square root of sum of
39* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
40*
41* Arguments
42* =========
43*
44* NORM (input) CHARACTER*1
45* Specifies the value to be returned in CLANHE as described
46* above.
47*
48* UPLO (input) CHARACTER*1
49* Specifies whether the upper or lower triangular part of the
50* hermitian matrix A is to be referenced.
51* = 'U': Upper triangular part of A is referenced
52* = 'L': Lower triangular part of A is referenced
53*
54* N (input) INTEGER
55* The order of the matrix A. N >= 0. When N = 0, CLANHE is
56* set to zero.
57*
58* A (input) COMPLEX array, dimension (LDA,N)
59* The hermitian matrix A. If UPLO = 'U', the leading n by n
60* upper triangular part of A contains the upper triangular part
61* of the matrix A, and the strictly lower triangular part of A
62* is not referenced. If UPLO = 'L', the leading n by n lower
63* triangular part of A contains the lower triangular part of
64* the matrix A, and the strictly upper triangular part of A is
65* not referenced. Note that the imaginary parts of the diagonal
66* elements need not be set and are assumed to be zero.
67*
68* LDA (input) INTEGER
69* The leading dimension of the array A. LDA >= max(N,1).
70*
71* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
72* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
73* WORK is not referenced.
74*
75* =====================================================================
76*
77* .. Parameters ..
78 REAL ONE, ZERO
79 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
80* ..
81* .. Local Scalars ..
82 INTEGER I, J
83 REAL ABSA, SCALE, SUM, VALUE
84* ..
85* .. External Functions ..
86 LOGICAL LSAME
87 EXTERNAL LSAME
88* ..
89* .. External Subroutines ..
90 EXTERNAL CLASSQ
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC ABS, MAX, REAL, SQRT
94* ..
95* .. Executable Statements ..
96*
97 IF( N.EQ.0 ) THEN
98 VALUE = ZERO
99 ELSE IF( LSAME( NORM, 'M' ) ) THEN
100*
101* Find max(abs(A(i,j))).
102*
103 VALUE = ZERO
104 IF( LSAME( UPLO, 'U' ) ) THEN
105 DO 20 J = 1, N
106 DO 10 I = 1, J - 1
107 VALUE = MAX( VALUE, ABS( A( I, J ) ) )
108 10 CONTINUE
109 VALUE = MAX( VALUE, ABS( REAL( A( J, J ) ) ) )
110 20 CONTINUE
111 ELSE
112 DO 40 J = 1, N
113 VALUE = MAX( VALUE, ABS( REAL( A( J, J ) ) ) )
114 DO 30 I = J + 1, N
115 VALUE = MAX( VALUE, ABS( A( I, J ) ) )
116 30 CONTINUE
117 40 CONTINUE
118 END IF
119 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
120 $ ( NORM.EQ.'1' ) ) THEN
121*
122* Find normI(A) ( = norm1(A), since A is hermitian).
123*
124 VALUE = ZERO
125 IF( LSAME( UPLO, 'U' ) ) THEN
126 DO 60 J = 1, N
127 SUM = ZERO
128 DO 50 I = 1, J - 1
129 ABSA = ABS( A( I, J ) )
130 SUM = SUM + ABSA
131 WORK( I ) = WORK( I ) + ABSA
132 50 CONTINUE
133 WORK( J ) = SUM + ABS( REAL( A( J, J ) ) )
134 60 CONTINUE
135 DO 70 I = 1, N
136 VALUE = MAX( VALUE, WORK( I ) )
137 70 CONTINUE
138 ELSE
139 DO 80 I = 1, N
140 WORK( I ) = ZERO
141 80 CONTINUE
142 DO 100 J = 1, N
143 SUM = WORK( J ) + ABS( REAL( A( J, J ) ) )
144 DO 90 I = J + 1, N
145 ABSA = ABS( A( I, J ) )
146 SUM = SUM + ABSA
147 WORK( I ) = WORK( I ) + ABSA
148 90 CONTINUE
149 VALUE = MAX( VALUE, SUM )
150 100 CONTINUE
151 END IF
152 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
153*
154* Find normF(A).
155*
156 SCALE = ZERO
157 SUM = ONE
158 IF( LSAME( UPLO, 'U' ) ) THEN
159 DO 110 J = 2, N
160 CALL CLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
161 110 CONTINUE
162 ELSE
163 DO 120 J = 1, N - 1
164 CALL CLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
165 120 CONTINUE
166 END IF
167 SUM = 2*SUM
168 DO 130 I = 1, N
169 IF( REAL( A( I, I ) ).NE.ZERO ) THEN
170 ABSA = ABS( REAL( A( I, I ) ) )
171 IF( SCALE.LT.ABSA ) THEN
172 SUM = ONE + SUM*( SCALE / ABSA )**2
173 SCALE = ABSA
174 ELSE
175 SUM = SUM + ( ABSA / SCALE )**2
176 END IF
177 END IF
178 130 CONTINUE
179 VALUE = SCALE*SQRT( SUM )
180 END IF
181*
182 CLANHE = VALUE
183 RETURN
184*
185* End of CLANHE
186*
187 END
Note: See TracBrowser for help on using the repository browser.