1: DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK )
2: *
3: * -- LAPACK auxiliary routine (version 3.2) --
4: * -- LAPACK is a software package provided by Univ. of Tennessee, --
5: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6: * November 2006
7: *
8: * .. Scalar Arguments ..
9: CHARACTER DIAG, NORM, UPLO
10: INTEGER N
11: * ..
12: * .. Array Arguments ..
13: DOUBLE PRECISION WORK( * )
14: COMPLEX*16 AP( * )
15: * ..
16: *
17: * Purpose
18: * =======
19: *
20: * ZLANTP returns the value of the one norm, or the Frobenius norm, or
21: * the infinity norm, or the element of largest absolute value of a
22: * triangular matrix A, supplied in packed form.
23: *
24: * Description
25: * ===========
26: *
27: * ZLANTP returns the value
28: *
29: * ZLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
30: * (
31: * ( norm1(A), NORM = '1', 'O' or 'o'
32: * (
33: * ( normI(A), NORM = 'I' or 'i'
34: * (
35: * ( normF(A), NORM = 'F', 'f', 'E' or 'e'
36: *
37: * where norm1 denotes the one norm of a matrix (maximum column sum),
38: * normI denotes the infinity norm of a matrix (maximum row sum) and
39: * normF denotes the Frobenius norm of a matrix (square root of sum of
40: * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
41: *
42: * Arguments
43: * =========
44: *
45: * NORM (input) CHARACTER*1
46: * Specifies the value to be returned in ZLANTP as described
47: * above.
48: *
49: * UPLO (input) CHARACTER*1
50: * Specifies whether the matrix A is upper or lower triangular.
51: * = 'U': Upper triangular
52: * = 'L': Lower triangular
53: *
54: * DIAG (input) CHARACTER*1
55: * Specifies whether or not the matrix A is unit triangular.
56: * = 'N': Non-unit triangular
57: * = 'U': Unit triangular
58: *
59: * N (input) INTEGER
60: * The order of the matrix A. N >= 0. When N = 0, ZLANTP is
61: * set to zero.
62: *
63: * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
64: * The upper or lower triangular matrix A, packed columnwise in
65: * a linear array. The j-th column of A is stored in the array
66: * AP as follows:
67: * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
68: * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
69: * Note that when DIAG = 'U', the elements of the array AP
70: * corresponding to the diagonal elements of the matrix A are
71: * not referenced, but are assumed to be one.
72: *
73: * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
74: * where LWORK >= N when NORM = 'I'; otherwise, WORK is not
75: * referenced.
76: *
77: * =====================================================================
78: *
79: * .. Parameters ..
80: DOUBLE PRECISION ONE, ZERO
81: PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
82: * ..
83: * .. Local Scalars ..
84: LOGICAL UDIAG
85: INTEGER I, J, K
86: DOUBLE PRECISION SCALE, SUM, VALUE
87: * ..
88: * .. External Functions ..
89: LOGICAL LSAME
90: EXTERNAL LSAME
91: * ..
92: * .. External Subroutines ..
93: EXTERNAL ZLASSQ
94: * ..
95: * .. Intrinsic Functions ..
96: INTRINSIC ABS, MAX, SQRT
97: * ..
98: * .. Executable Statements ..
99: *
100: IF( N.EQ.0 ) THEN
101: VALUE = ZERO
102: ELSE IF( LSAME( NORM, 'M' ) ) THEN
103: *
104: * Find max(abs(A(i,j))).
105: *
106: K = 1
107: IF( LSAME( DIAG, 'U' ) ) THEN
108: VALUE = ONE
109: IF( LSAME( UPLO, 'U' ) ) THEN
110: DO 20 J = 1, N
111: DO 10 I = K, K + J - 2
112: VALUE = MAX( VALUE, ABS( AP( I ) ) )
113: 10 CONTINUE
114: K = K + J
115: 20 CONTINUE
116: ELSE
117: DO 40 J = 1, N
118: DO 30 I = K + 1, K + N - J
119: VALUE = MAX( VALUE, ABS( AP( I ) ) )
120: 30 CONTINUE
121: K = K + N - J + 1
122: 40 CONTINUE
123: END IF
124: ELSE
125: VALUE = ZERO
126: IF( LSAME( UPLO, 'U' ) ) THEN
127: DO 60 J = 1, N
128: DO 50 I = K, K + J - 1
129: VALUE = MAX( VALUE, ABS( AP( I ) ) )
130: 50 CONTINUE
131: K = K + J
132: 60 CONTINUE
133: ELSE
134: DO 80 J = 1, N
135: DO 70 I = K, K + N - J
136: VALUE = MAX( VALUE, ABS( AP( I ) ) )
137: 70 CONTINUE
138: K = K + N - J + 1
139: 80 CONTINUE
140: END IF
141: END IF
142: ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
143: *
144: * Find norm1(A).
145: *
146: VALUE = ZERO
147: K = 1
148: UDIAG = LSAME( DIAG, 'U' )
149: IF( LSAME( UPLO, 'U' ) ) THEN
150: DO 110 J = 1, N
151: IF( UDIAG ) THEN
152: SUM = ONE
153: DO 90 I = K, K + J - 2
154: SUM = SUM + ABS( AP( I ) )
155: 90 CONTINUE
156: ELSE
157: SUM = ZERO
158: DO 100 I = K, K + J - 1
159: SUM = SUM + ABS( AP( I ) )
160: 100 CONTINUE
161: END IF
162: K = K + J
163: VALUE = MAX( VALUE, SUM )
164: 110 CONTINUE
165: ELSE
166: DO 140 J = 1, N
167: IF( UDIAG ) THEN
168: SUM = ONE
169: DO 120 I = K + 1, K + N - J
170: SUM = SUM + ABS( AP( I ) )
171: 120 CONTINUE
172: ELSE
173: SUM = ZERO
174: DO 130 I = K, K + N - J
175: SUM = SUM + ABS( AP( I ) )
176: 130 CONTINUE
177: END IF
178: K = K + N - J + 1
179: VALUE = MAX( VALUE, SUM )
180: 140 CONTINUE
181: END IF
182: ELSE IF( LSAME( NORM, 'I' ) ) THEN
183: *
184: * Find normI(A).
185: *
186: K = 1
187: IF( LSAME( UPLO, 'U' ) ) THEN
188: IF( LSAME( DIAG, 'U' ) ) THEN
189: DO 150 I = 1, N
190: WORK( I ) = ONE
191: 150 CONTINUE
192: DO 170 J = 1, N
193: DO 160 I = 1, J - 1
194: WORK( I ) = WORK( I ) + ABS( AP( K ) )
195: K = K + 1
196: 160 CONTINUE
197: K = K + 1
198: 170 CONTINUE
199: ELSE
200: DO 180 I = 1, N
201: WORK( I ) = ZERO
202: 180 CONTINUE
203: DO 200 J = 1, N
204: DO 190 I = 1, J
205: WORK( I ) = WORK( I ) + ABS( AP( K ) )
206: K = K + 1
207: 190 CONTINUE
208: 200 CONTINUE
209: END IF
210: ELSE
211: IF( LSAME( DIAG, 'U' ) ) THEN
212: DO 210 I = 1, N
213: WORK( I ) = ONE
214: 210 CONTINUE
215: DO 230 J = 1, N
216: K = K + 1
217: DO 220 I = J + 1, N
218: WORK( I ) = WORK( I ) + ABS( AP( K ) )
219: K = K + 1
220: 220 CONTINUE
221: 230 CONTINUE
222: ELSE
223: DO 240 I = 1, N
224: WORK( I ) = ZERO
225: 240 CONTINUE
226: DO 260 J = 1, N
227: DO 250 I = J, N
228: WORK( I ) = WORK( I ) + ABS( AP( K ) )
229: K = K + 1
230: 250 CONTINUE
231: 260 CONTINUE
232: END IF
233: END IF
234: VALUE = ZERO
235: DO 270 I = 1, N
236: VALUE = MAX( VALUE, WORK( I ) )
237: 270 CONTINUE
238: ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
239: *
240: * Find normF(A).
241: *
242: IF( LSAME( UPLO, 'U' ) ) THEN
243: IF( LSAME( DIAG, 'U' ) ) THEN
244: SCALE = ONE
245: SUM = N
246: K = 2
247: DO 280 J = 2, N
248: CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
249: K = K + J
250: 280 CONTINUE
251: ELSE
252: SCALE = ZERO
253: SUM = ONE
254: K = 1
255: DO 290 J = 1, N
256: CALL ZLASSQ( J, AP( K ), 1, SCALE, SUM )
257: K = K + J
258: 290 CONTINUE
259: END IF
260: ELSE
261: IF( LSAME( DIAG, 'U' ) ) THEN
262: SCALE = ONE
263: SUM = N
264: K = 2
265: DO 300 J = 1, N - 1
266: CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
267: K = K + N - J + 1
268: 300 CONTINUE
269: ELSE
270: SCALE = ZERO
271: SUM = ONE
272: K = 1
273: DO 310 J = 1, N
274: CALL ZLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
275: K = K + N - J + 1
276: 310 CONTINUE
277: END IF
278: END IF
279: VALUE = SCALE*SQRT( SUM )
280: END IF
281: *
282: ZLANTP = VALUE
283: RETURN
284: *
285: * End of ZLANTP
286: *
287: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zlantp.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack