LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
zlanhf.f
Go to the documentation of this file.
1*> \brief \b ZLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian matrix in RFP format.
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> Download ZLANHF + dependencies
9*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlanhf.f">
10*> [TGZ]</a>
11*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlanhf.f">
12*> [ZIP]</a>
13*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlanhf.f">
14*> [TXT]</a>
15*
16* Definition:
17* ===========
18*
19* DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK )
20*
21* .. Scalar Arguments ..
22* CHARACTER NORM, TRANSR, UPLO
23* INTEGER N
24* ..
25* .. Array Arguments ..
26* DOUBLE PRECISION WORK( 0: * )
27* COMPLEX*16 A( 0: * )
28* ..
29*
30*
31*> \par Purpose:
32* =============
33*>
34*> \verbatim
35*>
36*> ZLANHF returns the value of the one norm, or the Frobenius norm, or
37*> the infinity norm, or the element of largest absolute value of a
38*> complex Hermitian matrix A in RFP format.
39*> \endverbatim
40*>
41*> \return ZLANHF
42*> \verbatim
43*>
44*> ZLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'
45*> (
46*> ( norm1(A), NORM = '1', 'O' or 'o'
47*> (
48*> ( normI(A), NORM = 'I' or 'i'
49*> (
50*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
51*>
52*> where norm1 denotes the one norm of a matrix (maximum column sum),
53*> normI denotes the infinity norm of a matrix (maximum row sum) and
54*> normF denotes the Frobenius norm of a matrix (square root of sum of
55*> squares). Note that max(abs(A(i,j))) is not a matrix norm.
56*> \endverbatim
57*
58* Arguments:
59* ==========
60*
61*> \param[in] NORM
62*> \verbatim
63*> NORM is CHARACTER
64*> Specifies the value to be returned in ZLANHF as described
65*> above.
66*> \endverbatim
67*>
68*> \param[in] TRANSR
69*> \verbatim
70*> TRANSR is CHARACTER
71*> Specifies whether the RFP format of A is normal or
72*> conjugate-transposed format.
73*> = 'N': RFP format is Normal
74*> = 'C': RFP format is Conjugate-transposed
75*> \endverbatim
76*>
77*> \param[in] UPLO
78*> \verbatim
79*> UPLO is CHARACTER
80*> On entry, UPLO specifies whether the RFP matrix A came from
81*> an upper or lower triangular matrix as follows:
82*>
83*> UPLO = 'U' or 'u' RFP A came from an upper triangular
84*> matrix
85*>
86*> UPLO = 'L' or 'l' RFP A came from a lower triangular
87*> matrix
88*> \endverbatim
89*>
90*> \param[in] N
91*> \verbatim
92*> N is INTEGER
93*> The order of the matrix A. N >= 0. When N = 0, ZLANHF is
94*> set to zero.
95*> \endverbatim
96*>
97*> \param[in] A
98*> \verbatim
99*> A is COMPLEX*16 array, dimension ( N*(N+1)/2 );
100*> On entry, the matrix A in RFP Format.
101*> RFP Format is described by TRANSR, UPLO and N as follows:
102*> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
103*> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
104*> TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A
105*> as defined when TRANSR = 'N'. The contents of RFP A are
106*> defined by UPLO as follows: If UPLO = 'U' the RFP A
107*> contains the ( N*(N+1)/2 ) elements of upper packed A
108*> either in normal or conjugate-transpose Format. If
109*> UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements
110*> of lower packed A either in normal or conjugate-transpose
111*> Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When
112*> TRANSR is 'N' the LDA is N+1 when N is even and is N when
113*> is odd. See the Note below for more details.
114*> Unchanged on exit.
115*> \endverbatim
116*>
117*> \param[out] WORK
118*> \verbatim
119*> WORK is DOUBLE PRECISION array, dimension (LWORK),
120*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
121*> WORK is not referenced.
122*> \endverbatim
123*
124* Authors:
125* ========
126*
127*> \author Univ. of Tennessee
128*> \author Univ. of California Berkeley
129*> \author Univ. of Colorado Denver
130*> \author NAG Ltd.
131*
132*> \ingroup lanhf
133*
134*> \par Further Details:
135* =====================
136*>
137*> \verbatim
138*>
139*> We first consider Standard Packed Format when N is even.
140*> We give an example where N = 6.
141*>
142*> AP is Upper AP is Lower
143*>
144*> 00 01 02 03 04 05 00
145*> 11 12 13 14 15 10 11
146*> 22 23 24 25 20 21 22
147*> 33 34 35 30 31 32 33
148*> 44 45 40 41 42 43 44
149*> 55 50 51 52 53 54 55
150*>
151*>
152*> Let TRANSR = 'N'. RFP holds AP as follows:
153*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
154*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of
155*> conjugate-transpose of the first three columns of AP upper.
156*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
157*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of
158*> conjugate-transpose of the last three columns of AP lower.
159*> To denote conjugate we place -- above the element. This covers the
160*> case N even and TRANSR = 'N'.
161*>
162*> RFP A RFP A
163*>
164*> -- -- --
165*> 03 04 05 33 43 53
166*> -- --
167*> 13 14 15 00 44 54
168*> --
169*> 23 24 25 10 11 55
170*>
171*> 33 34 35 20 21 22
172*> --
173*> 00 44 45 30 31 32
174*> -- --
175*> 01 11 55 40 41 42
176*> -- -- --
177*> 02 12 22 50 51 52
178*>
179*> Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
180*> transpose of RFP A above. One therefore gets:
181*>
182*>
183*> RFP A RFP A
184*>
185*> -- -- -- -- -- -- -- -- -- --
186*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50
187*> -- -- -- -- -- -- -- -- -- --
188*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51
189*> -- -- -- -- -- -- -- -- -- --
190*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52
191*>
192*>
193*> We next consider Standard Packed Format when N is odd.
194*> We give an example where N = 5.
195*>
196*> AP is Upper AP is Lower
197*>
198*> 00 01 02 03 04 00
199*> 11 12 13 14 10 11
200*> 22 23 24 20 21 22
201*> 33 34 30 31 32 33
202*> 44 40 41 42 43 44
203*>
204*>
205*> Let TRANSR = 'N'. RFP holds AP as follows:
206*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
207*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of
208*> conjugate-transpose of the first two columns of AP upper.
209*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
210*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of
211*> conjugate-transpose of the last two columns of AP lower.
212*> To denote conjugate we place -- above the element. This covers the
213*> case N odd and TRANSR = 'N'.
214*>
215*> RFP A RFP A
216*>
217*> -- --
218*> 02 03 04 00 33 43
219*> --
220*> 12 13 14 10 11 44
221*>
222*> 22 23 24 20 21 22
223*> --
224*> 00 33 34 30 31 32
225*> -- --
226*> 01 11 44 40 41 42
227*>
228*> Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
229*> transpose of RFP A above. One therefore gets:
230*>
231*>
232*> RFP A RFP A
233*>
234*> -- -- -- -- -- -- -- -- --
235*> 02 12 22 00 01 00 10 20 30 40 50
236*> -- -- -- -- -- -- -- -- --
237*> 03 13 23 33 11 33 11 21 31 41 51
238*> -- -- -- -- -- -- -- -- --
239*> 04 14 24 34 44 43 44 22 32 42 52
240*> \endverbatim
241*>
242* =====================================================================
243 DOUBLE PRECISION FUNCTION zlanhf( NORM, TRANSR, UPLO, N, A,
244 $ WORK )
245*
246* -- LAPACK computational routine --
247* -- LAPACK is a software package provided by Univ. of Tennessee, --
248* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
249*
250* .. Scalar Arguments ..
251 CHARACTER norm, transr, uplo
252 INTEGER n
253* ..
254* .. Array Arguments ..
255 DOUBLE PRECISION work( 0: * )
256 COMPLEX*16 a( 0: * )
257* ..
258*
259* =====================================================================
260*
261* .. Parameters ..
262 DOUBLE PRECISION one, zero
263 parameter( one = 1.0d+0, zero = 0.0d+0 )
264* ..
265* .. Local Scalars ..
266 INTEGER i, j, ifm, ilu, noe, n1, k, l, lda
267 DOUBLE PRECISION scale, s, VALUE, aa, temp
268* ..
269* .. External Functions ..
270 LOGICAL lsame, disnan
271 EXTERNAL lsame, disnan
272* ..
273* .. External Subroutines ..
274 EXTERNAL zlassq
275* ..
276* .. Intrinsic Functions ..
277 INTRINSIC abs, dble, sqrt
278* ..
279* .. Executable Statements ..
280*
281 IF( n.EQ.0 ) THEN
282 zlanhf = zero
283 RETURN
284 ELSE IF( n.EQ.1 ) THEN
285 zlanhf = abs(dble(a(0)))
286 RETURN
287 END IF
288*
289* set noe = 1 if n is odd. if n is even set noe=0
290*
291 noe = 1
292 IF( mod( n, 2 ).EQ.0 )
293 $ noe = 0
294*
295* set ifm = 0 when form='C' or 'c' and 1 otherwise
296*
297 ifm = 1
298 IF( lsame( transr, 'C' ) )
299 $ ifm = 0
300*
301* set ilu = 0 when uplo='U or 'u' and 1 otherwise
302*
303 ilu = 1
304 IF( lsame( uplo, 'U' ) )
305 $ ilu = 0
306*
307* set lda = (n+1)/2 when ifm = 0
308* set lda = n when ifm = 1 and noe = 1
309* set lda = n+1 when ifm = 1 and noe = 0
310*
311 IF( ifm.EQ.1 ) THEN
312 IF( noe.EQ.1 ) THEN
313 lda = n
314 ELSE
315* noe=0
316 lda = n + 1
317 END IF
318 ELSE
319* ifm=0
320 lda = ( n+1 ) / 2
321 END IF
322*
323 IF( lsame( norm, 'M' ) ) THEN
324*
325* Find max(abs(A(i,j))).
326*
327 k = ( n+1 ) / 2
328 VALUE = zero
329 IF( noe.EQ.1 ) THEN
330* n is odd & n = k + k - 1
331 IF( ifm.EQ.1 ) THEN
332* A is n by k
333 IF( ilu.EQ.1 ) THEN
334* uplo ='L'
335 j = 0
336* -> L(0,0)
337 temp = abs( dble( a( j+j*lda ) ) )
338 IF( VALUE .LT. temp .OR. disnan( temp ) )
339 $ VALUE = temp
340 DO i = 1, n - 1
341 temp = abs( a( i+j*lda ) )
342 IF( VALUE .LT. temp .OR. disnan( temp ) )
343 $ VALUE = temp
344 END DO
345 DO j = 1, k - 1
346 DO i = 0, j - 2
347 temp = abs( a( i+j*lda ) )
348 IF( VALUE .LT. temp .OR. disnan( temp ) )
349 $ VALUE = temp
350 END DO
351 i = j - 1
352* L(k+j,k+j)
353 temp = abs( dble( a( i+j*lda ) ) )
354 IF( VALUE .LT. temp .OR. disnan( temp ) )
355 $ VALUE = temp
356 i = j
357* -> L(j,j)
358 temp = abs( dble( a( i+j*lda ) ) )
359 IF( VALUE .LT. temp .OR. disnan( temp ) )
360 $ VALUE = temp
361 DO i = j + 1, n - 1
362 temp = abs( a( i+j*lda ) )
363 IF( VALUE .LT. temp .OR. disnan( temp ) )
364 $ VALUE = temp
365 END DO
366 END DO
367 ELSE
368* uplo = 'U'
369 DO j = 0, k - 2
370 DO i = 0, k + j - 2
371 temp = abs( a( i+j*lda ) )
372 IF( VALUE .LT. temp .OR. disnan( temp ) )
373 $ VALUE = temp
374 END DO
375 i = k + j - 1
376* -> U(i,i)
377 temp = abs( dble( a( i+j*lda ) ) )
378 IF( VALUE .LT. temp .OR. disnan( temp ) )
379 $ VALUE = temp
380 i = i + 1
381* =k+j; i -> U(j,j)
382 temp = abs( dble( a( i+j*lda ) ) )
383 IF( VALUE .LT. temp .OR. disnan( temp ) )
384 $ VALUE = temp
385 DO i = k + j + 1, n - 1
386 temp = abs( a( i+j*lda ) )
387 IF( VALUE .LT. temp .OR. disnan( temp ) )
388 $ VALUE = temp
389 END DO
390 END DO
391 DO i = 0, n - 2
392 temp = abs( a( i+j*lda ) )
393 IF( VALUE .LT. temp .OR. disnan( temp ) )
394 $ VALUE = temp
395* j=k-1
396 END DO
397* i=n-1 -> U(n-1,n-1)
398 temp = abs( dble( a( i+j*lda ) ) )
399 IF( VALUE .LT. temp .OR. disnan( temp ) )
400 $ VALUE = temp
401 END IF
402 ELSE
403* xpose case; A is k by n
404 IF( ilu.EQ.1 ) THEN
405* uplo ='L'
406 DO j = 0, k - 2
407 DO i = 0, j - 1
408 temp = abs( a( i+j*lda ) )
409 IF( VALUE .LT. temp .OR. disnan( temp ) )
410 $ VALUE = temp
411 END DO
412 i = j
413* L(i,i)
414 temp = abs( dble( a( i+j*lda ) ) )
415 IF( VALUE .LT. temp .OR. disnan( temp ) )
416 $ VALUE = temp
417 i = j + 1
418* L(j+k,j+k)
419 temp = abs( dble( a( i+j*lda ) ) )
420 IF( VALUE .LT. temp .OR. disnan( temp ) )
421 $ VALUE = temp
422 DO i = j + 2, k - 1
423 temp = abs( a( i+j*lda ) )
424 IF( VALUE .LT. temp .OR. disnan( temp ) )
425 $ VALUE = temp
426 END DO
427 END DO
428 j = k - 1
429 DO i = 0, k - 2
430 temp = abs( a( i+j*lda ) )
431 IF( VALUE .LT. temp .OR. disnan( temp ) )
432 $ VALUE = temp
433 END DO
434 i = k - 1
435* -> L(i,i) is at A(i,j)
436 temp = abs( dble( a( i+j*lda ) ) )
437 IF( VALUE .LT. temp .OR. disnan( temp ) )
438 $ VALUE = temp
439 DO j = k, n - 1
440 DO i = 0, k - 1
441 temp = abs( a( i+j*lda ) )
442 IF( VALUE .LT. temp .OR. disnan( temp ) )
443 $ VALUE = temp
444 END DO
445 END DO
446 ELSE
447* uplo = 'U'
448 DO j = 0, k - 2
449 DO i = 0, k - 1
450 temp = abs( a( i+j*lda ) )
451 IF( VALUE .LT. temp .OR. disnan( temp ) )
452 $ VALUE = temp
453 END DO
454 END DO
455 j = k - 1
456* -> U(j,j) is at A(0,j)
457 temp = abs( dble( a( 0+j*lda ) ) )
458 IF( VALUE .LT. temp .OR. disnan( temp ) )
459 $ VALUE = temp
460 DO i = 1, k - 1
461 temp = abs( a( i+j*lda ) )
462 IF( VALUE .LT. temp .OR. disnan( temp ) )
463 $ VALUE = temp
464 END DO
465 DO j = k, n - 1
466 DO i = 0, j - k - 1
467 temp = abs( a( i+j*lda ) )
468 IF( VALUE .LT. temp .OR. disnan( temp ) )
469 $ VALUE = temp
470 END DO
471 i = j - k
472* -> U(i,i) at A(i,j)
473 temp = abs( dble( a( i+j*lda ) ) )
474 IF( VALUE .LT. temp .OR. disnan( temp ) )
475 $ VALUE = temp
476 i = j - k + 1
477* U(j,j)
478 temp = abs( dble( a( i+j*lda ) ) )
479 IF( VALUE .LT. temp .OR. disnan( temp ) )
480 $ VALUE = temp
481 DO i = j - k + 2, k - 1
482 temp = abs( a( i+j*lda ) )
483 IF( VALUE .LT. temp .OR. disnan( temp ) )
484 $ VALUE = temp
485 END DO
486 END DO
487 END IF
488 END IF
489 ELSE
490* n is even & k = n/2
491 IF( ifm.EQ.1 ) THEN
492* A is n+1 by k
493 IF( ilu.EQ.1 ) THEN
494* uplo ='L'
495 j = 0
496* -> L(k,k) & j=1 -> L(0,0)
497 temp = abs( dble( a( j+j*lda ) ) )
498 IF( VALUE .LT. temp .OR. disnan( temp ) )
499 $ VALUE = temp
500 temp = abs( dble( a( j+1+j*lda ) ) )
501 IF( VALUE .LT. temp .OR. disnan( temp ) )
502 $ VALUE = temp
503 DO i = 2, n
504 temp = abs( a( i+j*lda ) )
505 IF( VALUE .LT. temp .OR. disnan( temp ) )
506 $ VALUE = temp
507 END DO
508 DO j = 1, k - 1
509 DO i = 0, j - 1
510 temp = abs( a( i+j*lda ) )
511 IF( VALUE .LT. temp .OR. disnan( temp ) )
512 $ VALUE = temp
513 END DO
514 i = j
515* L(k+j,k+j)
516 temp = abs( dble( a( i+j*lda ) ) )
517 IF( VALUE .LT. temp .OR. disnan( temp ) )
518 $ VALUE = temp
519 i = j + 1
520* -> L(j,j)
521 temp = abs( dble( a( i+j*lda ) ) )
522 IF( VALUE .LT. temp .OR. disnan( temp ) )
523 $ VALUE = temp
524 DO i = j + 2, n
525 temp = abs( a( i+j*lda ) )
526 IF( VALUE .LT. temp .OR. disnan( temp ) )
527 $ VALUE = temp
528 END DO
529 END DO
530 ELSE
531* uplo = 'U'
532 DO j = 0, k - 2
533 DO i = 0, k + j - 1
534 temp = abs( a( i+j*lda ) )
535 IF( VALUE .LT. temp .OR. disnan( temp ) )
536 $ VALUE = temp
537 END DO
538 i = k + j
539* -> U(i,i)
540 temp = abs( dble( a( i+j*lda ) ) )
541 IF( VALUE .LT. temp .OR. disnan( temp ) )
542 $ VALUE = temp
543 i = i + 1
544* =k+j+1; i -> U(j,j)
545 temp = abs( dble( a( i+j*lda ) ) )
546 IF( VALUE .LT. temp .OR. disnan( temp ) )
547 $ VALUE = temp
548 DO i = k + j + 2, n
549 temp = abs( a( i+j*lda ) )
550 IF( VALUE .LT. temp .OR. disnan( temp ) )
551 $ VALUE = temp
552 END DO
553 END DO
554 DO i = 0, n - 2
555 temp = abs( a( i+j*lda ) )
556 IF( VALUE .LT. temp .OR. disnan( temp ) )
557 $ VALUE = temp
558* j=k-1
559 END DO
560* i=n-1 -> U(n-1,n-1)
561 temp = abs( dble( a( i+j*lda ) ) )
562 IF( VALUE .LT. temp .OR. disnan( temp ) )
563 $ VALUE = temp
564 i = n
565* -> U(k-1,k-1)
566 temp = abs( dble( a( i+j*lda ) ) )
567 IF( VALUE .LT. temp .OR. disnan( temp ) )
568 $ VALUE = temp
569 END IF
570 ELSE
571* xpose case; A is k by n+1
572 IF( ilu.EQ.1 ) THEN
573* uplo ='L'
574 j = 0
575* -> L(k,k) at A(0,0)
576 temp = abs( dble( a( j+j*lda ) ) )
577 IF( VALUE .LT. temp .OR. disnan( temp ) )
578 $ VALUE = temp
579 DO i = 1, k - 1
580 temp = abs( a( i+j*lda ) )
581 IF( VALUE .LT. temp .OR. disnan( temp ) )
582 $ VALUE = temp
583 END DO
584 DO j = 1, k - 1
585 DO i = 0, j - 2
586 temp = abs( a( i+j*lda ) )
587 IF( VALUE .LT. temp .OR. disnan( temp ) )
588 $ VALUE = temp
589 END DO
590 i = j - 1
591* L(i,i)
592 temp = abs( dble( a( i+j*lda ) ) )
593 IF( VALUE .LT. temp .OR. disnan( temp ) )
594 $ VALUE = temp
595 i = j
596* L(j+k,j+k)
597 temp = abs( dble( a( i+j*lda ) ) )
598 IF( VALUE .LT. temp .OR. disnan( temp ) )
599 $ VALUE = temp
600 DO i = j + 1, k - 1
601 temp = abs( a( i+j*lda ) )
602 IF( VALUE .LT. temp .OR. disnan( temp ) )
603 $ VALUE = temp
604 END DO
605 END DO
606 j = k
607 DO i = 0, k - 2
608 temp = abs( a( i+j*lda ) )
609 IF( VALUE .LT. temp .OR. disnan( temp ) )
610 $ VALUE = temp
611 END DO
612 i = k - 1
613* -> L(i,i) is at A(i,j)
614 temp = abs( dble( a( i+j*lda ) ) )
615 IF( VALUE .LT. temp .OR. disnan( temp ) )
616 $ VALUE = temp
617 DO j = k + 1, n
618 DO i = 0, k - 1
619 temp = abs( a( i+j*lda ) )
620 IF( VALUE .LT. temp .OR. disnan( temp ) )
621 $ VALUE = temp
622 END DO
623 END DO
624 ELSE
625* uplo = 'U'
626 DO j = 0, k - 1
627 DO i = 0, k - 1
628 temp = abs( a( i+j*lda ) )
629 IF( VALUE .LT. temp .OR. disnan( temp ) )
630 $ VALUE = temp
631 END DO
632 END DO
633 j = k
634* -> U(j,j) is at A(0,j)
635 temp = abs( dble( a( 0+j*lda ) ) )
636 IF( VALUE .LT. temp .OR. disnan( temp ) )
637 $ VALUE = temp
638 DO i = 1, k - 1
639 temp = abs( a( i+j*lda ) )
640 IF( VALUE .LT. temp .OR. disnan( temp ) )
641 $ VALUE = temp
642 END DO
643 DO j = k + 1, n - 1
644 DO i = 0, j - k - 2
645 temp = abs( a( i+j*lda ) )
646 IF( VALUE .LT. temp .OR. disnan( temp ) )
647 $ VALUE = temp
648 END DO
649 i = j - k - 1
650* -> U(i,i) at A(i,j)
651 temp = abs( dble( a( i+j*lda ) ) )
652 IF( VALUE .LT. temp .OR. disnan( temp ) )
653 $ VALUE = temp
654 i = j - k
655* U(j,j)
656 temp = abs( dble( a( i+j*lda ) ) )
657 IF( VALUE .LT. temp .OR. disnan( temp ) )
658 $ VALUE = temp
659 DO i = j - k + 1, k - 1
660 temp = abs( a( i+j*lda ) )
661 IF( VALUE .LT. temp .OR. disnan( temp ) )
662 $ VALUE = temp
663 END DO
664 END DO
665 j = n
666 DO i = 0, k - 2
667 temp = abs( a( i+j*lda ) )
668 IF( VALUE .LT. temp .OR. disnan( temp ) )
669 $ VALUE = temp
670 END DO
671 i = k - 1
672* U(k,k) at A(i,j)
673 temp = abs( dble( a( i+j*lda ) ) )
674 IF( VALUE .LT. temp .OR. disnan( temp ) )
675 $ VALUE = temp
676 END IF
677 END IF
678 END IF
679 ELSE IF( ( lsame( norm, 'I' ) ) .OR.
680 $ ( lsame( norm, 'O' ) ) .OR.
681 $ ( norm.EQ.'1' ) ) THEN
682*
683* Find normI(A) ( = norm1(A), since A is Hermitian).
684*
685 IF( ifm.EQ.1 ) THEN
686* A is 'N'
687 k = n / 2
688 IF( noe.EQ.1 ) THEN
689* n is odd & A is n by (n+1)/2
690 IF( ilu.EQ.0 ) THEN
691* uplo = 'U'
692 DO i = 0, k - 1
693 work( i ) = zero
694 END DO
695 DO j = 0, k
696 s = zero
697 DO i = 0, k + j - 1
698 aa = abs( a( i+j*lda ) )
699* -> A(i,j+k)
700 s = s + aa
701 work( i ) = work( i ) + aa
702 END DO
703 aa = abs( dble( a( i+j*lda ) ) )
704* -> A(j+k,j+k)
705 work( j+k ) = s + aa
706 IF( i.EQ.k+k )
707 $ GO TO 10
708 i = i + 1
709 aa = abs( dble( a( i+j*lda ) ) )
710* -> A(j,j)
711 work( j ) = work( j ) + aa
712 s = zero
713 DO l = j + 1, k - 1
714 i = i + 1
715 aa = abs( a( i+j*lda ) )
716* -> A(l,j)
717 s = s + aa
718 work( l ) = work( l ) + aa
719 END DO
720 work( j ) = work( j ) + s
721 END DO
722 10 CONTINUE
723 VALUE = work( 0 )
724 DO i = 1, n-1
725 temp = work( i )
726 IF( VALUE .LT. temp .OR. disnan( temp ) )
727 $ VALUE = temp
728 END DO
729 ELSE
730* ilu = 1 & uplo = 'L'
731 k = k + 1
732* k=(n+1)/2 for n odd and ilu=1
733 DO i = k, n - 1
734 work( i ) = zero
735 END DO
736 DO j = k - 1, 0, -1
737 s = zero
738 DO i = 0, j - 2
739 aa = abs( a( i+j*lda ) )
740* -> A(j+k,i+k)
741 s = s + aa
742 work( i+k ) = work( i+k ) + aa
743 END DO
744 IF( j.GT.0 ) THEN
745 aa = abs( dble( a( i+j*lda ) ) )
746* -> A(j+k,j+k)
747 s = s + aa
748 work( i+k ) = work( i+k ) + s
749* i=j
750 i = i + 1
751 END IF
752 aa = abs( dble( a( i+j*lda ) ) )
753* -> A(j,j)
754 work( j ) = aa
755 s = zero
756 DO l = j + 1, n - 1
757 i = i + 1
758 aa = abs( a( i+j*lda ) )
759* -> A(l,j)
760 s = s + aa
761 work( l ) = work( l ) + aa
762 END DO
763 work( j ) = work( j ) + s
764 END DO
765 VALUE = work( 0 )
766 DO i = 1, n-1
767 temp = work( i )
768 IF( VALUE .LT. temp .OR. disnan( temp ) )
769 $ VALUE = temp
770 END DO
771 END IF
772 ELSE
773* n is even & A is n+1 by k = n/2
774 IF( ilu.EQ.0 ) THEN
775* uplo = 'U'
776 DO i = 0, k - 1
777 work( i ) = zero
778 END DO
779 DO j = 0, k - 1
780 s = zero
781 DO i = 0, k + j - 1
782 aa = abs( a( i+j*lda ) )
783* -> A(i,j+k)
784 s = s + aa
785 work( i ) = work( i ) + aa
786 END DO
787 aa = abs( dble( a( i+j*lda ) ) )
788* -> A(j+k,j+k)
789 work( j+k ) = s + aa
790 i = i + 1
791 aa = abs( dble( a( i+j*lda ) ) )
792* -> A(j,j)
793 work( j ) = work( j ) + aa
794 s = zero
795 DO l = j + 1, k - 1
796 i = i + 1
797 aa = abs( a( i+j*lda ) )
798* -> A(l,j)
799 s = s + aa
800 work( l ) = work( l ) + aa
801 END DO
802 work( j ) = work( j ) + s
803 END DO
804 VALUE = work( 0 )
805 DO i = 1, n-1
806 temp = work( i )
807 IF( VALUE .LT. temp .OR. disnan( temp ) )
808 $ VALUE = temp
809 END DO
810 ELSE
811* ilu = 1 & uplo = 'L'
812 DO i = k, n - 1
813 work( i ) = zero
814 END DO
815 DO j = k - 1, 0, -1
816 s = zero
817 DO i = 0, j - 1
818 aa = abs( a( i+j*lda ) )
819* -> A(j+k,i+k)
820 s = s + aa
821 work( i+k ) = work( i+k ) + aa
822 END DO
823 aa = abs( dble( a( i+j*lda ) ) )
824* -> A(j+k,j+k)
825 s = s + aa
826 work( i+k ) = work( i+k ) + s
827* i=j
828 i = i + 1
829 aa = abs( dble( a( i+j*lda ) ) )
830* -> A(j,j)
831 work( j ) = aa
832 s = zero
833 DO l = j + 1, n - 1
834 i = i + 1
835 aa = abs( a( i+j*lda ) )
836* -> A(l,j)
837 s = s + aa
838 work( l ) = work( l ) + aa
839 END DO
840 work( j ) = work( j ) + s
841 END DO
842 VALUE = work( 0 )
843 DO i = 1, n-1
844 temp = work( i )
845 IF( VALUE .LT. temp .OR. disnan( temp ) )
846 $ VALUE = temp
847 END DO
848 END IF
849 END IF
850 ELSE
851* ifm=0
852 k = n / 2
853 IF( noe.EQ.1 ) THEN
854* n is odd & A is (n+1)/2 by n
855 IF( ilu.EQ.0 ) THEN
856* uplo = 'U'
857 n1 = k
858* n/2
859 k = k + 1
860* k is the row size and lda
861 DO i = n1, n - 1
862 work( i ) = zero
863 END DO
864 DO j = 0, n1 - 1
865 s = zero
866 DO i = 0, k - 1
867 aa = abs( a( i+j*lda ) )
868* A(j,n1+i)
869 work( i+n1 ) = work( i+n1 ) + aa
870 s = s + aa
871 END DO
872 work( j ) = s
873 END DO
874* j=n1=k-1 is special
875 s = abs( dble( a( 0+j*lda ) ) )
876* A(k-1,k-1)
877 DO i = 1, k - 1
878 aa = abs( a( i+j*lda ) )
879* A(k-1,i+n1)
880 work( i+n1 ) = work( i+n1 ) + aa
881 s = s + aa
882 END DO
883 work( j ) = work( j ) + s
884 DO j = k, n - 1
885 s = zero
886 DO i = 0, j - k - 1
887 aa = abs( a( i+j*lda ) )
888* A(i,j-k)
889 work( i ) = work( i ) + aa
890 s = s + aa
891 END DO
892* i=j-k
893 aa = abs( dble( a( i+j*lda ) ) )
894* A(j-k,j-k)
895 s = s + aa
896 work( j-k ) = work( j-k ) + s
897 i = i + 1
898 s = abs( dble( a( i+j*lda ) ) )
899* A(j,j)
900 DO l = j + 1, n - 1
901 i = i + 1
902 aa = abs( a( i+j*lda ) )
903* A(j,l)
904 work( l ) = work( l ) + aa
905 s = s + aa
906 END DO
907 work( j ) = work( j ) + s
908 END DO
909 VALUE = work( 0 )
910 DO i = 1, n-1
911 temp = work( i )
912 IF( VALUE .LT. temp .OR. disnan( temp ) )
913 $ VALUE = temp
914 END DO
915 ELSE
916* ilu=1 & uplo = 'L'
917 k = k + 1
918* k=(n+1)/2 for n odd and ilu=1
919 DO i = k, n - 1
920 work( i ) = zero
921 END DO
922 DO j = 0, k - 2
923* process
924 s = zero
925 DO i = 0, j - 1
926 aa = abs( a( i+j*lda ) )
927* A(j,i)
928 work( i ) = work( i ) + aa
929 s = s + aa
930 END DO
931 aa = abs( dble( a( i+j*lda ) ) )
932* i=j so process of A(j,j)
933 s = s + aa
934 work( j ) = s
935* is initialised here
936 i = i + 1
937* i=j process A(j+k,j+k)
938 aa = abs( dble( a( i+j*lda ) ) )
939 s = aa
940 DO l = k + j + 1, n - 1
941 i = i + 1
942 aa = abs( a( i+j*lda ) )
943* A(l,k+j)
944 s = s + aa
945 work( l ) = work( l ) + aa
946 END DO
947 work( k+j ) = work( k+j ) + s
948 END DO
949* j=k-1 is special :process col A(k-1,0:k-1)
950 s = zero
951 DO i = 0, k - 2
952 aa = abs( a( i+j*lda ) )
953* A(k,i)
954 work( i ) = work( i ) + aa
955 s = s + aa
956 END DO
957* i=k-1
958 aa = abs( dble( a( i+j*lda ) ) )
959* A(k-1,k-1)
960 s = s + aa
961 work( i ) = s
962* done with col j=k+1
963 DO j = k, n - 1
964* process col j of A = A(j,0:k-1)
965 s = zero
966 DO i = 0, k - 1
967 aa = abs( a( i+j*lda ) )
968* A(j,i)
969 work( i ) = work( i ) + aa
970 s = s + aa
971 END DO
972 work( j ) = work( j ) + s
973 END DO
974 VALUE = work( 0 )
975 DO i = 1, n-1
976 temp = work( i )
977 IF( VALUE .LT. temp .OR. disnan( temp ) )
978 $ VALUE = temp
979 END DO
980 END IF
981 ELSE
982* n is even & A is k=n/2 by n+1
983 IF( ilu.EQ.0 ) THEN
984* uplo = 'U'
985 DO i = k, n - 1
986 work( i ) = zero
987 END DO
988 DO j = 0, k - 1
989 s = zero
990 DO i = 0, k - 1
991 aa = abs( a( i+j*lda ) )
992* A(j,i+k)
993 work( i+k ) = work( i+k ) + aa
994 s = s + aa
995 END DO
996 work( j ) = s
997 END DO
998* j=k
999 aa = abs( dble( a( 0+j*lda ) ) )
1000* A(k,k)
1001 s = aa
1002 DO i = 1, k - 1
1003 aa = abs( a( i+j*lda ) )
1004* A(k,k+i)
1005 work( i+k ) = work( i+k ) + aa
1006 s = s + aa
1007 END DO
1008 work( j ) = work( j ) + s
1009 DO j = k + 1, n - 1
1010 s = zero
1011 DO i = 0, j - 2 - k
1012 aa = abs( a( i+j*lda ) )
1013* A(i,j-k-1)
1014 work( i ) = work( i ) + aa
1015 s = s + aa
1016 END DO
1017* i=j-1-k
1018 aa = abs( dble( a( i+j*lda ) ) )
1019* A(j-k-1,j-k-1)
1020 s = s + aa
1021 work( j-k-1 ) = work( j-k-1 ) + s
1022 i = i + 1
1023 aa = abs( dble( a( i+j*lda ) ) )
1024* A(j,j)
1025 s = aa
1026 DO l = j + 1, n - 1
1027 i = i + 1
1028 aa = abs( a( i+j*lda ) )
1029* A(j,l)
1030 work( l ) = work( l ) + aa
1031 s = s + aa
1032 END DO
1033 work( j ) = work( j ) + s
1034 END DO
1035* j=n
1036 s = zero
1037 DO i = 0, k - 2
1038 aa = abs( a( i+j*lda ) )
1039* A(i,k-1)
1040 work( i ) = work( i ) + aa
1041 s = s + aa
1042 END DO
1043* i=k-1
1044 aa = abs( dble( a( i+j*lda ) ) )
1045* A(k-1,k-1)
1046 s = s + aa
1047 work( i ) = work( i ) + s
1048 VALUE = work( 0 )
1049 DO i = 1, n-1
1050 temp = work( i )
1051 IF( VALUE .LT. temp .OR. disnan( temp ) )
1052 $ VALUE = temp
1053 END DO
1054 ELSE
1055* ilu=1 & uplo = 'L'
1056 DO i = k, n - 1
1057 work( i ) = zero
1058 END DO
1059* j=0 is special :process col A(k:n-1,k)
1060 s = abs( dble( a( 0 ) ) )
1061* A(k,k)
1062 DO i = 1, k - 1
1063 aa = abs( a( i ) )
1064* A(k+i,k)
1065 work( i+k ) = work( i+k ) + aa
1066 s = s + aa
1067 END DO
1068 work( k ) = work( k ) + s
1069 DO j = 1, k - 1
1070* process
1071 s = zero
1072 DO i = 0, j - 2
1073 aa = abs( a( i+j*lda ) )
1074* A(j-1,i)
1075 work( i ) = work( i ) + aa
1076 s = s + aa
1077 END DO
1078 aa = abs( dble( a( i+j*lda ) ) )
1079* i=j-1 so process of A(j-1,j-1)
1080 s = s + aa
1081 work( j-1 ) = s
1082* is initialised here
1083 i = i + 1
1084* i=j process A(j+k,j+k)
1085 aa = abs( dble( a( i+j*lda ) ) )
1086 s = aa
1087 DO l = k + j + 1, n - 1
1088 i = i + 1
1089 aa = abs( a( i+j*lda ) )
1090* A(l,k+j)
1091 s = s + aa
1092 work( l ) = work( l ) + aa
1093 END DO
1094 work( k+j ) = work( k+j ) + s
1095 END DO
1096* j=k is special :process col A(k,0:k-1)
1097 s = zero
1098 DO i = 0, k - 2
1099 aa = abs( a( i+j*lda ) )
1100* A(k,i)
1101 work( i ) = work( i ) + aa
1102 s = s + aa
1103 END DO
1104*
1105* i=k-1
1106 aa = abs( dble( a( i+j*lda ) ) )
1107* A(k-1,k-1)
1108 s = s + aa
1109 work( i ) = s
1110* done with col j=k+1
1111 DO j = k + 1, n
1112*
1113* process col j-1 of A = A(j-1,0:k-1)
1114 s = zero
1115 DO i = 0, k - 1
1116 aa = abs( a( i+j*lda ) )
1117* A(j-1,i)
1118 work( i ) = work( i ) + aa
1119 s = s + aa
1120 END DO
1121 work( j-1 ) = work( j-1 ) + s
1122 END DO
1123 VALUE = work( 0 )
1124 DO i = 1, n-1
1125 temp = work( i )
1126 IF( VALUE .LT. temp .OR. disnan( temp ) )
1127 $ VALUE = temp
1128 END DO
1129 END IF
1130 END IF
1131 END IF
1132 ELSE IF( ( lsame( norm, 'F' ) ) .OR.
1133 $ ( lsame( norm, 'E' ) ) ) THEN
1134*
1135* Find normF(A).
1136*
1137 k = ( n+1 ) / 2
1138 scale = zero
1139 s = one
1140 IF( noe.EQ.1 ) THEN
1141* n is odd
1142 IF( ifm.EQ.1 ) THEN
1143* A is normal & A is n by k
1144 IF( ilu.EQ.0 ) THEN
1145* A is upper
1146 DO j = 0, k - 3
1147 CALL zlassq( k-j-2, a( k+j+1+j*lda ), 1, scale,
1148 $ s )
1149* L at A(k,0)
1150 END DO
1151 DO j = 0, k - 1
1152 CALL zlassq( k+j-1, a( 0+j*lda ), 1, scale, s )
1153* trap U at A(0,0)
1154 END DO
1155 s = s + s
1156* double s for the off diagonal elements
1157 l = k - 1
1158* -> U(k,k) at A(k-1,0)
1159 DO i = 0, k - 2
1160 aa = dble( a( l ) )
1161* U(k+i,k+i)
1162 IF( aa.NE.zero ) THEN
1163 IF( scale.LT.aa ) THEN
1164 s = one + s*( scale / aa )**2
1165 scale = aa
1166 ELSE
1167 s = s + ( aa / scale )**2
1168 END IF
1169 END IF
1170 aa = dble( a( l+1 ) )
1171* U(i,i)
1172 IF( aa.NE.zero ) THEN
1173 IF( scale.LT.aa ) THEN
1174 s = one + s*( scale / aa )**2
1175 scale = aa
1176 ELSE
1177 s = s + ( aa / scale )**2
1178 END IF
1179 END IF
1180 l = l + lda + 1
1181 END DO
1182 aa = dble( a( l ) )
1183* U(n-1,n-1)
1184 IF( aa.NE.zero ) THEN
1185 IF( scale.LT.aa ) THEN
1186 s = one + s*( scale / aa )**2
1187 scale = aa
1188 ELSE
1189 s = s + ( aa / scale )**2
1190 END IF
1191 END IF
1192 ELSE
1193* ilu=1 & A is lower
1194 DO j = 0, k - 1
1195 CALL zlassq( n-j-1, a( j+1+j*lda ), 1, scale,
1196 $ s )
1197* trap L at A(0,0)
1198 END DO
1199 DO j = 1, k - 2
1200 CALL zlassq( j, a( 0+( 1+j )*lda ), 1, scale,
1201 $ s )
1202* U at A(0,1)
1203 END DO
1204 s = s + s
1205* double s for the off diagonal elements
1206 aa = dble( a( 0 ) )
1207* L(0,0) at A(0,0)
1208 IF( aa.NE.zero ) THEN
1209 IF( scale.LT.aa ) THEN
1210 s = one + s*( scale / aa )**2
1211 scale = aa
1212 ELSE
1213 s = s + ( aa / scale )**2
1214 END IF
1215 END IF
1216 l = lda
1217* -> L(k,k) at A(0,1)
1218 DO i = 1, k - 1
1219 aa = dble( a( l ) )
1220* L(k-1+i,k-1+i)
1221 IF( aa.NE.zero ) THEN
1222 IF( scale.LT.aa ) THEN
1223 s = one + s*( scale / aa )**2
1224 scale = aa
1225 ELSE
1226 s = s + ( aa / scale )**2
1227 END IF
1228 END IF
1229 aa = dble( a( l+1 ) )
1230* L(i,i)
1231 IF( aa.NE.zero ) THEN
1232 IF( scale.LT.aa ) THEN
1233 s = one + s*( scale / aa )**2
1234 scale = aa
1235 ELSE
1236 s = s + ( aa / scale )**2
1237 END IF
1238 END IF
1239 l = l + lda + 1
1240 END DO
1241 END IF
1242 ELSE
1243* A is xpose & A is k by n
1244 IF( ilu.EQ.0 ) THEN
1245* A**H is upper
1246 DO j = 1, k - 2
1247 CALL zlassq( j, a( 0+( k+j )*lda ), 1, scale,
1248 $ s )
1249* U at A(0,k)
1250 END DO
1251 DO j = 0, k - 2
1252 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1253* k by k-1 rect. at A(0,0)
1254 END DO
1255 DO j = 0, k - 2
1256 CALL zlassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,
1257 $ scale, s )
1258* L at A(0,k-1)
1259 END DO
1260 s = s + s
1261* double s for the off diagonal elements
1262 l = 0 + k*lda - lda
1263* -> U(k-1,k-1) at A(0,k-1)
1264 aa = dble( a( l ) )
1265* U(k-1,k-1)
1266 IF( aa.NE.zero ) THEN
1267 IF( scale.LT.aa ) THEN
1268 s = one + s*( scale / aa )**2
1269 scale = aa
1270 ELSE
1271 s = s + ( aa / scale )**2
1272 END IF
1273 END IF
1274 l = l + lda
1275* -> U(0,0) at A(0,k)
1276 DO j = k, n - 1
1277 aa = dble( a( l ) )
1278* -> U(j-k,j-k)
1279 IF( aa.NE.zero ) THEN
1280 IF( scale.LT.aa ) THEN
1281 s = one + s*( scale / aa )**2
1282 scale = aa
1283 ELSE
1284 s = s + ( aa / scale )**2
1285 END IF
1286 END IF
1287 aa = dble( a( l+1 ) )
1288* -> U(j,j)
1289 IF( aa.NE.zero ) THEN
1290 IF( scale.LT.aa ) THEN
1291 s = one + s*( scale / aa )**2
1292 scale = aa
1293 ELSE
1294 s = s + ( aa / scale )**2
1295 END IF
1296 END IF
1297 l = l + lda + 1
1298 END DO
1299 ELSE
1300* A**H is lower
1301 DO j = 1, k - 1
1302 CALL zlassq( j, a( 0+j*lda ), 1, scale, s )
1303* U at A(0,0)
1304 END DO
1305 DO j = k, n - 1
1306 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1307* k by k-1 rect. at A(0,k)
1308 END DO
1309 DO j = 0, k - 3
1310 CALL zlassq( k-j-2, a( j+2+j*lda ), 1, scale,
1311 $ s )
1312* L at A(1,0)
1313 END DO
1314 s = s + s
1315* double s for the off diagonal elements
1316 l = 0
1317* -> L(0,0) at A(0,0)
1318 DO i = 0, k - 2
1319 aa = dble( a( l ) )
1320* L(i,i)
1321 IF( aa.NE.zero ) THEN
1322 IF( scale.LT.aa ) THEN
1323 s = one + s*( scale / aa )**2
1324 scale = aa
1325 ELSE
1326 s = s + ( aa / scale )**2
1327 END IF
1328 END IF
1329 aa = dble( a( l+1 ) )
1330* L(k+i,k+i)
1331 IF( aa.NE.zero ) THEN
1332 IF( scale.LT.aa ) THEN
1333 s = one + s*( scale / aa )**2
1334 scale = aa
1335 ELSE
1336 s = s + ( aa / scale )**2
1337 END IF
1338 END IF
1339 l = l + lda + 1
1340 END DO
1341* L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1)
1342 aa = dble( a( l ) )
1343* L(k-1,k-1) at A(k-1,k-1)
1344 IF( aa.NE.zero ) THEN
1345 IF( scale.LT.aa ) THEN
1346 s = one + s*( scale / aa )**2
1347 scale = aa
1348 ELSE
1349 s = s + ( aa / scale )**2
1350 END IF
1351 END IF
1352 END IF
1353 END IF
1354 ELSE
1355* n is even
1356 IF( ifm.EQ.1 ) THEN
1357* A is normal
1358 IF( ilu.EQ.0 ) THEN
1359* A is upper
1360 DO j = 0, k - 2
1361 CALL zlassq( k-j-1, a( k+j+2+j*lda ), 1, scale,
1362 $ s )
1363* L at A(k+1,0)
1364 END DO
1365 DO j = 0, k - 1
1366 CALL zlassq( k+j, a( 0+j*lda ), 1, scale, s )
1367* trap U at A(0,0)
1368 END DO
1369 s = s + s
1370* double s for the off diagonal elements
1371 l = k
1372* -> U(k,k) at A(k,0)
1373 DO i = 0, k - 1
1374 aa = dble( a( l ) )
1375* U(k+i,k+i)
1376 IF( aa.NE.zero ) THEN
1377 IF( scale.LT.aa ) THEN
1378 s = one + s*( scale / aa )**2
1379 scale = aa
1380 ELSE
1381 s = s + ( aa / scale )**2
1382 END IF
1383 END IF
1384 aa = dble( a( l+1 ) )
1385* U(i,i)
1386 IF( aa.NE.zero ) THEN
1387 IF( scale.LT.aa ) THEN
1388 s = one + s*( scale / aa )**2
1389 scale = aa
1390 ELSE
1391 s = s + ( aa / scale )**2
1392 END IF
1393 END IF
1394 l = l + lda + 1
1395 END DO
1396 ELSE
1397* ilu=1 & A is lower
1398 DO j = 0, k - 1
1399 CALL zlassq( n-j-1, a( j+2+j*lda ), 1, scale,
1400 $ s )
1401* trap L at A(1,0)
1402 END DO
1403 DO j = 1, k - 1
1404 CALL zlassq( j, a( 0+j*lda ), 1, scale, s )
1405* U at A(0,0)
1406 END DO
1407 s = s + s
1408* double s for the off diagonal elements
1409 l = 0
1410* -> L(k,k) at A(0,0)
1411 DO i = 0, k - 1
1412 aa = dble( a( l ) )
1413* L(k-1+i,k-1+i)
1414 IF( aa.NE.zero ) THEN
1415 IF( scale.LT.aa ) THEN
1416 s = one + s*( scale / aa )**2
1417 scale = aa
1418 ELSE
1419 s = s + ( aa / scale )**2
1420 END IF
1421 END IF
1422 aa = dble( a( l+1 ) )
1423* L(i,i)
1424 IF( aa.NE.zero ) THEN
1425 IF( scale.LT.aa ) THEN
1426 s = one + s*( scale / aa )**2
1427 scale = aa
1428 ELSE
1429 s = s + ( aa / scale )**2
1430 END IF
1431 END IF
1432 l = l + lda + 1
1433 END DO
1434 END IF
1435 ELSE
1436* A is xpose
1437 IF( ilu.EQ.0 ) THEN
1438* A**H is upper
1439 DO j = 1, k - 1
1440 CALL zlassq( j, a( 0+( k+1+j )*lda ), 1, scale,
1441 $ s )
1442* U at A(0,k+1)
1443 END DO
1444 DO j = 0, k - 1
1445 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1446* k by k rect. at A(0,0)
1447 END DO
1448 DO j = 0, k - 2
1449 CALL zlassq( k-j-1, a( j+1+( j+k )*lda ), 1,
1450 $ scale,
1451 $ s )
1452* L at A(0,k)
1453 END DO
1454 s = s + s
1455* double s for the off diagonal elements
1456 l = 0 + k*lda
1457* -> U(k,k) at A(0,k)
1458 aa = dble( a( l ) )
1459* U(k,k)
1460 IF( aa.NE.zero ) THEN
1461 IF( scale.LT.aa ) THEN
1462 s = one + s*( scale / aa )**2
1463 scale = aa
1464 ELSE
1465 s = s + ( aa / scale )**2
1466 END IF
1467 END IF
1468 l = l + lda
1469* -> U(0,0) at A(0,k+1)
1470 DO j = k + 1, n - 1
1471 aa = dble( a( l ) )
1472* -> U(j-k-1,j-k-1)
1473 IF( aa.NE.zero ) THEN
1474 IF( scale.LT.aa ) THEN
1475 s = one + s*( scale / aa )**2
1476 scale = aa
1477 ELSE
1478 s = s + ( aa / scale )**2
1479 END IF
1480 END IF
1481 aa = dble( a( l+1 ) )
1482* -> U(j,j)
1483 IF( aa.NE.zero ) THEN
1484 IF( scale.LT.aa ) THEN
1485 s = one + s*( scale / aa )**2
1486 scale = aa
1487 ELSE
1488 s = s + ( aa / scale )**2
1489 END IF
1490 END IF
1491 l = l + lda + 1
1492 END DO
1493* L=k-1+n*lda
1494* -> U(k-1,k-1) at A(k-1,n)
1495 aa = dble( a( l ) )
1496* U(k,k)
1497 IF( aa.NE.zero ) THEN
1498 IF( scale.LT.aa ) THEN
1499 s = one + s*( scale / aa )**2
1500 scale = aa
1501 ELSE
1502 s = s + ( aa / scale )**2
1503 END IF
1504 END IF
1505 ELSE
1506* A**H is lower
1507 DO j = 1, k - 1
1508 CALL zlassq( j, a( 0+( j+1 )*lda ), 1, scale,
1509 $ s )
1510* U at A(0,1)
1511 END DO
1512 DO j = k + 1, n
1513 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1514* k by k rect. at A(0,k+1)
1515 END DO
1516 DO j = 0, k - 2
1517 CALL zlassq( k-j-1, a( j+1+j*lda ), 1, scale,
1518 $ s )
1519* L at A(0,0)
1520 END DO
1521 s = s + s
1522* double s for the off diagonal elements
1523 l = 0
1524* -> L(k,k) at A(0,0)
1525 aa = dble( a( l ) )
1526* L(k,k) at A(0,0)
1527 IF( aa.NE.zero ) THEN
1528 IF( scale.LT.aa ) THEN
1529 s = one + s*( scale / aa )**2
1530 scale = aa
1531 ELSE
1532 s = s + ( aa / scale )**2
1533 END IF
1534 END IF
1535 l = lda
1536* -> L(0,0) at A(0,1)
1537 DO i = 0, k - 2
1538 aa = dble( a( l ) )
1539* L(i,i)
1540 IF( aa.NE.zero ) THEN
1541 IF( scale.LT.aa ) THEN
1542 s = one + s*( scale / aa )**2
1543 scale = aa
1544 ELSE
1545 s = s + ( aa / scale )**2
1546 END IF
1547 END IF
1548 aa = dble( a( l+1 ) )
1549* L(k+i+1,k+i+1)
1550 IF( aa.NE.zero ) THEN
1551 IF( scale.LT.aa ) THEN
1552 s = one + s*( scale / aa )**2
1553 scale = aa
1554 ELSE
1555 s = s + ( aa / scale )**2
1556 END IF
1557 END IF
1558 l = l + lda + 1
1559 END DO
1560* L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k)
1561 aa = dble( a( l ) )
1562* L(k-1,k-1) at A(k-1,k)
1563 IF( aa.NE.zero ) THEN
1564 IF( scale.LT.aa ) THEN
1565 s = one + s*( scale / aa )**2
1566 scale = aa
1567 ELSE
1568 s = s + ( aa / scale )**2
1569 END IF
1570 END IF
1571 END IF
1572 END IF
1573 END IF
1574 VALUE = scale*sqrt( s )
1575 END IF
1576*
1577 zlanhf = VALUE
1578 RETURN
1579*
1580* End of ZLANHF
1581*
1582 END
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:57
zlanhf
double precision function zlanhf(norm, transr, uplo, n, a, work)
ZLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhf.f:245
zlassq
subroutine zlassq(n, x, incx, scale, sumsq)
ZLASSQ updates a sum of squares represented in scaled form.
Definition zlassq.f90:122
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48