LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
slansf.f
Go to the documentation of this file.
1 *> \brief \b SLANSF
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download SLANSF + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slansf.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slansf.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slansf.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )
22 *
23 * .. Scalar Arguments ..
24 * CHARACTER NORM, TRANSR, UPLO
25 * INTEGER N
26 * ..
27 * .. Array Arguments ..
28 * REAL A( 0: * ), WORK( 0: * )
29 * ..
30 *
31 *
32 *> \par Purpose:
33 * =============
34 *>
35 *> \verbatim
36 *>
37 *> SLANSF returns the value of the one norm, or the Frobenius norm, or
38 *> the infinity norm, or the element of largest absolute value of a
39 *> real symmetric matrix A in RFP format.
40 *> \endverbatim
41 *>
42 *> \return SLANSF
43 *> \verbatim
44 *>
45 *> SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'
46 *> (
47 *> ( norm1(A), NORM = '1', 'O' or 'o'
48 *> (
49 *> ( normI(A), NORM = 'I' or 'i'
50 *> (
51 *> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
52 *>
53 *> where norm1 denotes the one norm of a matrix (maximum column sum),
54 *> normI denotes the infinity norm of a matrix (maximum row sum) and
55 *> normF denotes the Frobenius norm of a matrix (square root of sum of
56 *> squares). Note that max(abs(A(i,j))) is not a matrix norm.
57 *> \endverbatim
58 *
59 * Arguments:
60 * ==========
61 *
62 *> \param[in] NORM
63 *> \verbatim
64 *> NORM is CHARACTER*1
65 *> Specifies the value to be returned in SLANSF as described
66 *> above.
67 *> \endverbatim
68 *>
69 *> \param[in] TRANSR
70 *> \verbatim
71 *> TRANSR is CHARACTER*1
72 *> Specifies whether the RFP format of A is normal or
73 *> transposed format.
74 *> = 'N': RFP format is Normal;
75 *> = 'T': RFP format is Transpose.
76 *> \endverbatim
77 *>
78 *> \param[in] UPLO
79 *> \verbatim
80 *> UPLO is CHARACTER*1
81 *> On entry, UPLO specifies whether the RFP matrix A came from
82 *> an upper or lower triangular matrix as follows:
83 *> = 'U': RFP A came from an upper triangular matrix;
84 *> = 'L': RFP A came from a lower triangular matrix.
85 *> \endverbatim
86 *>
87 *> \param[in] N
88 *> \verbatim
89 *> N is INTEGER
90 *> The order of the matrix A. N >= 0. When N = 0, SLANSF is
91 *> set to zero.
92 *> \endverbatim
93 *>
94 *> \param[in] A
95 *> \verbatim
96 *> A is REAL array, dimension ( N*(N+1)/2 );
97 *> On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
98 *> part of the symmetric matrix A stored in RFP format. See the
99 *> "Notes" below for more details.
100 *> Unchanged on exit.
101 *> \endverbatim
102 *>
103 *> \param[out] WORK
104 *> \verbatim
105 *> WORK is REAL array, dimension (MAX(1,LWORK)),
106 *> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
107 *> WORK is not referenced.
108 *> \endverbatim
109 *
110 * Authors:
111 * ========
112 *
113 *> \author Univ. of Tennessee
114 *> \author Univ. of California Berkeley
115 *> \author Univ. of Colorado Denver
116 *> \author NAG Ltd.
117 *
118 *> \ingroup realOTHERcomputational
119 *
120 *> \par Further Details:
121 * =====================
122 *>
123 *> \verbatim
124 *>
125 *> We first consider Rectangular Full Packed (RFP) Format when N is
126 *> even. We give an example where N = 6.
127 *>
128 *> AP is Upper AP is Lower
129 *>
130 *> 00 01 02 03 04 05 00
131 *> 11 12 13 14 15 10 11
132 *> 22 23 24 25 20 21 22
133 *> 33 34 35 30 31 32 33
134 *> 44 45 40 41 42 43 44
135 *> 55 50 51 52 53 54 55
136 *>
137 *>
138 *> Let TRANSR = 'N'. RFP holds AP as follows:
139 *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
140 *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of
141 *> the transpose of the first three columns of AP upper.
142 *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
143 *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of
144 *> the transpose of the last three columns of AP lower.
145 *> This covers the case N even and TRANSR = 'N'.
146 *>
147 *> RFP A RFP A
148 *>
149 *> 03 04 05 33 43 53
150 *> 13 14 15 00 44 54
151 *> 23 24 25 10 11 55
152 *> 33 34 35 20 21 22
153 *> 00 44 45 30 31 32
154 *> 01 11 55 40 41 42
155 *> 02 12 22 50 51 52
156 *>
157 *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
158 *> transpose of RFP A above. One therefore gets:
159 *>
160 *>
161 *> RFP A RFP A
162 *>
163 *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50
164 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51
165 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52
166 *>
167 *>
168 *> We then consider Rectangular Full Packed (RFP) Format when N is
169 *> odd. We give an example where N = 5.
170 *>
171 *> AP is Upper AP is Lower
172 *>
173 *> 00 01 02 03 04 00
174 *> 11 12 13 14 10 11
175 *> 22 23 24 20 21 22
176 *> 33 34 30 31 32 33
177 *> 44 40 41 42 43 44
178 *>
179 *>
180 *> Let TRANSR = 'N'. RFP holds AP as follows:
181 *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
182 *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of
183 *> the transpose of the first two columns of AP upper.
184 *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
185 *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of
186 *> the transpose of the last two columns of AP lower.
187 *> This covers the case N odd and TRANSR = 'N'.
188 *>
189 *> RFP A RFP A
190 *>
191 *> 02 03 04 00 33 43
192 *> 12 13 14 10 11 44
193 *> 22 23 24 20 21 22
194 *> 00 33 34 30 31 32
195 *> 01 11 44 40 41 42
196 *>
197 *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
198 *> transpose of RFP A above. One therefore gets:
199 *>
200 *> RFP A RFP A
201 *>
202 *> 02 12 22 00 01 00 10 20 30 40 50
203 *> 03 13 23 33 11 33 11 21 31 41 51
204 *> 04 14 24 34 44 43 44 22 32 42 52
205 *> \endverbatim
206 *
207 * =====================================================================
208  REAL function slansf( norm, transr, uplo, n, a, work )
209 *
210 * -- LAPACK computational routine --
211 * -- LAPACK is a software package provided by Univ. of Tennessee, --
212 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
213 *
214 * .. Scalar Arguments ..
215  CHARACTER norm, transr, uplo
216  INTEGER n
217 * ..
218 * .. Array Arguments ..
219  REAL a( 0: * ), work( 0: * )
220 * ..
221 *
222 * =====================================================================
223 *
224 * ..
225 * .. Parameters ..
226  REAL one, zero
227  parameter( one = 1.0e+0, zero = 0.0e+0 )
228 * ..
229 * .. Local Scalars ..
230  INTEGER i, j, ifm, ilu, noe, n1, k, l, lda
231  REAL scale, s, VALUE, aa, temp
232 * ..
233 * .. External Functions ..
234  LOGICAL lsame, sisnan
235  EXTERNAL lsame, sisnan
236 * ..
237 * .. External Subroutines ..
238  EXTERNAL slassq
239 * ..
240 * .. Intrinsic Functions ..
241  INTRINSIC abs, sqrt
242 * ..
243 * .. Executable Statements ..
244 *
245  IF( n.EQ.0 ) THEN
246  slansf = zero
247  RETURN
248  ELSE IF( n.EQ.1 ) THEN
249  slansf = abs( a(0) )
250  RETURN
251  END IF
252 *
253 * set noe = 1 if n is odd. if n is even set noe=0
254 *
255  noe = 1
256  IF( mod( n, 2 ).EQ.0 )
257  $ noe = 0
258 *
259 * set ifm = 0 when form='T or 't' and 1 otherwise
260 *
261  ifm = 1
262  IF( lsame( transr, 'T' ) )
263  $ ifm = 0
264 *
265 * set ilu = 0 when uplo='U or 'u' and 1 otherwise
266 *
267  ilu = 1
268  IF( lsame( uplo, 'U' ) )
269  $ ilu = 0
270 *
271 * set lda = (n+1)/2 when ifm = 0
272 * set lda = n when ifm = 1 and noe = 1
273 * set lda = n+1 when ifm = 1 and noe = 0
274 *
275  IF( ifm.EQ.1 ) THEN
276  IF( noe.EQ.1 ) THEN
277  lda = n
278  ELSE
279 * noe=0
280  lda = n + 1
281  END IF
282  ELSE
283 * ifm=0
284  lda = ( n+1 ) / 2
285  END IF
286 *
287  IF( lsame( norm, 'M' ) ) THEN
288 *
289 * Find max(abs(A(i,j))).
290 *
291  k = ( n+1 ) / 2
292  VALUE = zero
293  IF( noe.EQ.1 ) THEN
294 * n is odd
295  IF( ifm.EQ.1 ) THEN
296 * A is n by k
297  DO j = 0, k - 1
298  DO i = 0, n - 1
299  temp = abs( a( i+j*lda ) )
300  IF( VALUE .LT. temp .OR. sisnan( temp ) )
301  $ VALUE = temp
302  END DO
303  END DO
304  ELSE
305 * xpose case; A is k by n
306  DO j = 0, n - 1
307  DO i = 0, k - 1
308  temp = abs( a( i+j*lda ) )
309  IF( VALUE .LT. temp .OR. sisnan( temp ) )
310  $ VALUE = temp
311  END DO
312  END DO
313  END IF
314  ELSE
315 * n is even
316  IF( ifm.EQ.1 ) THEN
317 * A is n+1 by k
318  DO j = 0, k - 1
319  DO i = 0, n
320  temp = abs( a( i+j*lda ) )
321  IF( VALUE .LT. temp .OR. sisnan( temp ) )
322  $ VALUE = temp
323  END DO
324  END DO
325  ELSE
326 * xpose case; A is k by n+1
327  DO j = 0, n
328  DO i = 0, k - 1
329  temp = abs( a( i+j*lda ) )
330  IF( VALUE .LT. temp .OR. sisnan( temp ) )
331  $ VALUE = temp
332  END DO
333  END DO
334  END IF
335  END IF
336  ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR.
337  $ ( norm.EQ.'1' ) ) THEN
338 *
339 * Find normI(A) ( = norm1(A), since A is symmetric).
340 *
341  IF( ifm.EQ.1 ) THEN
342  k = n / 2
343  IF( noe.EQ.1 ) THEN
344 * n is odd
345  IF( ilu.EQ.0 ) THEN
346  DO i = 0, k - 1
347  work( i ) = zero
348  END DO
349  DO j = 0, k
350  s = zero
351  DO i = 0, k + j - 1
352  aa = abs( a( i+j*lda ) )
353 * -> A(i,j+k)
354  s = s + aa
355  work( i ) = work( i ) + aa
356  END DO
357  aa = abs( a( i+j*lda ) )
358 * -> A(j+k,j+k)
359  work( j+k ) = s + aa
360  IF( i.EQ.k+k )
361  $ GO TO 10
362  i = i + 1
363  aa = abs( a( i+j*lda ) )
364 * -> A(j,j)
365  work( j ) = work( j ) + aa
366  s = zero
367  DO l = j + 1, k - 1
368  i = i + 1
369  aa = abs( a( i+j*lda ) )
370 * -> A(l,j)
371  s = s + aa
372  work( l ) = work( l ) + aa
373  END DO
374  work( j ) = work( j ) + s
375  END DO
376  10 CONTINUE
377  VALUE = work( 0 )
378  DO i = 1, n-1
379  temp = work( i )
380  IF( VALUE .LT. temp .OR. sisnan( temp ) )
381  $ VALUE = temp
382  END DO
383  ELSE
384 * ilu = 1
385  k = k + 1
386 * k=(n+1)/2 for n odd and ilu=1
387  DO i = k, n - 1
388  work( i ) = zero
389  END DO
390  DO j = k - 1, 0, -1
391  s = zero
392  DO i = 0, j - 2
393  aa = abs( a( i+j*lda ) )
394 * -> A(j+k,i+k)
395  s = s + aa
396  work( i+k ) = work( i+k ) + aa
397  END DO
398  IF( j.GT.0 ) THEN
399  aa = abs( a( i+j*lda ) )
400 * -> A(j+k,j+k)
401  s = s + aa
402  work( i+k ) = work( i+k ) + s
403 * i=j
404  i = i + 1
405  END IF
406  aa = abs( a( i+j*lda ) )
407 * -> A(j,j)
408  work( j ) = aa
409  s = zero
410  DO l = j + 1, n - 1
411  i = i + 1
412  aa = abs( a( i+j*lda ) )
413 * -> A(l,j)
414  s = s + aa
415  work( l ) = work( l ) + aa
416  END DO
417  work( j ) = work( j ) + s
418  END DO
419  VALUE = work( 0 )
420  DO i = 1, n-1
421  temp = work( i )
422  IF( VALUE .LT. temp .OR. sisnan( temp ) )
423  $ VALUE = temp
424  END DO
425  END IF
426  ELSE
427 * n is even
428  IF( ilu.EQ.0 ) THEN
429  DO i = 0, k - 1
430  work( i ) = zero
431  END DO
432  DO j = 0, k - 1
433  s = zero
434  DO i = 0, k + j - 1
435  aa = abs( a( i+j*lda ) )
436 * -> A(i,j+k)
437  s = s + aa
438  work( i ) = work( i ) + aa
439  END DO
440  aa = abs( a( i+j*lda ) )
441 * -> A(j+k,j+k)
442  work( j+k ) = s + aa
443  i = i + 1
444  aa = abs( a( i+j*lda ) )
445 * -> A(j,j)
446  work( j ) = work( j ) + aa
447  s = zero
448  DO l = j + 1, k - 1
449  i = i + 1
450  aa = abs( a( i+j*lda ) )
451 * -> A(l,j)
452  s = s + aa
453  work( l ) = work( l ) + aa
454  END DO
455  work( j ) = work( j ) + s
456  END DO
457  VALUE = work( 0 )
458  DO i = 1, n-1
459  temp = work( i )
460  IF( VALUE .LT. temp .OR. sisnan( temp ) )
461  $ VALUE = temp
462  END DO
463  ELSE
464 * ilu = 1
465  DO i = k, n - 1
466  work( i ) = zero
467  END DO
468  DO j = k - 1, 0, -1
469  s = zero
470  DO i = 0, j - 1
471  aa = abs( a( i+j*lda ) )
472 * -> A(j+k,i+k)
473  s = s + aa
474  work( i+k ) = work( i+k ) + aa
475  END DO
476  aa = abs( a( i+j*lda ) )
477 * -> A(j+k,j+k)
478  s = s + aa
479  work( i+k ) = work( i+k ) + s
480 * i=j
481  i = i + 1
482  aa = abs( a( i+j*lda ) )
483 * -> A(j,j)
484  work( j ) = aa
485  s = zero
486  DO l = j + 1, n - 1
487  i = i + 1
488  aa = abs( a( i+j*lda ) )
489 * -> A(l,j)
490  s = s + aa
491  work( l ) = work( l ) + aa
492  END DO
493  work( j ) = work( j ) + s
494  END DO
495  VALUE = work( 0 )
496  DO i = 1, n-1
497  temp = work( i )
498  IF( VALUE .LT. temp .OR. sisnan( temp ) )
499  $ VALUE = temp
500  END DO
501  END IF
502  END IF
503  ELSE
504 * ifm=0
505  k = n / 2
506  IF( noe.EQ.1 ) THEN
507 * n is odd
508  IF( ilu.EQ.0 ) THEN
509  n1 = k
510 * n/2
511  k = k + 1
512 * k is the row size and lda
513  DO i = n1, n - 1
514  work( i ) = zero
515  END DO
516  DO j = 0, n1 - 1
517  s = zero
518  DO i = 0, k - 1
519  aa = abs( a( i+j*lda ) )
520 * A(j,n1+i)
521  work( i+n1 ) = work( i+n1 ) + aa
522  s = s + aa
523  END DO
524  work( j ) = s
525  END DO
526 * j=n1=k-1 is special
527  s = abs( a( 0+j*lda ) )
528 * A(k-1,k-1)
529  DO i = 1, k - 1
530  aa = abs( a( i+j*lda ) )
531 * A(k-1,i+n1)
532  work( i+n1 ) = work( i+n1 ) + aa
533  s = s + aa
534  END DO
535  work( j ) = work( j ) + s
536  DO j = k, n - 1
537  s = zero
538  DO i = 0, j - k - 1
539  aa = abs( a( i+j*lda ) )
540 * A(i,j-k)
541  work( i ) = work( i ) + aa
542  s = s + aa
543  END DO
544 * i=j-k
545  aa = abs( a( i+j*lda ) )
546 * A(j-k,j-k)
547  s = s + aa
548  work( j-k ) = work( j-k ) + s
549  i = i + 1
550  s = abs( a( i+j*lda ) )
551 * A(j,j)
552  DO l = j + 1, n - 1
553  i = i + 1
554  aa = abs( a( i+j*lda ) )
555 * A(j,l)
556  work( l ) = work( l ) + aa
557  s = s + aa
558  END DO
559  work( j ) = work( j ) + s
560  END DO
561  VALUE = work( 0 )
562  DO i = 1, n-1
563  temp = work( i )
564  IF( VALUE .LT. temp .OR. sisnan( temp ) )
565  $ VALUE = temp
566  END DO
567  ELSE
568 * ilu=1
569  k = k + 1
570 * k=(n+1)/2 for n odd and ilu=1
571  DO i = k, n - 1
572  work( i ) = zero
573  END DO
574  DO j = 0, k - 2
575 * process
576  s = zero
577  DO i = 0, j - 1
578  aa = abs( a( i+j*lda ) )
579 * A(j,i)
580  work( i ) = work( i ) + aa
581  s = s + aa
582  END DO
583  aa = abs( a( i+j*lda ) )
584 * i=j so process of A(j,j)
585  s = s + aa
586  work( j ) = s
587 * is initialised here
588  i = i + 1
589 * i=j process A(j+k,j+k)
590  aa = abs( a( i+j*lda ) )
591  s = aa
592  DO l = k + j + 1, n - 1
593  i = i + 1
594  aa = abs( a( i+j*lda ) )
595 * A(l,k+j)
596  s = s + aa
597  work( l ) = work( l ) + aa
598  END DO
599  work( k+j ) = work( k+j ) + s
600  END DO
601 * j=k-1 is special :process col A(k-1,0:k-1)
602  s = zero
603  DO i = 0, k - 2
604  aa = abs( a( i+j*lda ) )
605 * A(k,i)
606  work( i ) = work( i ) + aa
607  s = s + aa
608  END DO
609 * i=k-1
610  aa = abs( a( i+j*lda ) )
611 * A(k-1,k-1)
612  s = s + aa
613  work( i ) = s
614 * done with col j=k+1
615  DO j = k, n - 1
616 * process col j of A = A(j,0:k-1)
617  s = zero
618  DO i = 0, k - 1
619  aa = abs( a( i+j*lda ) )
620 * A(j,i)
621  work( i ) = work( i ) + aa
622  s = s + aa
623  END DO
624  work( j ) = work( j ) + s
625  END DO
626  VALUE = work( 0 )
627  DO i = 1, n-1
628  temp = work( i )
629  IF( VALUE .LT. temp .OR. sisnan( temp ) )
630  $ VALUE = temp
631  END DO
632  END IF
633  ELSE
634 * n is even
635  IF( ilu.EQ.0 ) THEN
636  DO i = k, n - 1
637  work( i ) = zero
638  END DO
639  DO j = 0, k - 1
640  s = zero
641  DO i = 0, k - 1
642  aa = abs( a( i+j*lda ) )
643 * A(j,i+k)
644  work( i+k ) = work( i+k ) + aa
645  s = s + aa
646  END DO
647  work( j ) = s
648  END DO
649 * j=k
650  aa = abs( a( 0+j*lda ) )
651 * A(k,k)
652  s = aa
653  DO i = 1, k - 1
654  aa = abs( a( i+j*lda ) )
655 * A(k,k+i)
656  work( i+k ) = work( i+k ) + aa
657  s = s + aa
658  END DO
659  work( j ) = work( j ) + s
660  DO j = k + 1, n - 1
661  s = zero
662  DO i = 0, j - 2 - k
663  aa = abs( a( i+j*lda ) )
664 * A(i,j-k-1)
665  work( i ) = work( i ) + aa
666  s = s + aa
667  END DO
668 * i=j-1-k
669  aa = abs( a( i+j*lda ) )
670 * A(j-k-1,j-k-1)
671  s = s + aa
672  work( j-k-1 ) = work( j-k-1 ) + s
673  i = i + 1
674  aa = abs( a( i+j*lda ) )
675 * A(j,j)
676  s = aa
677  DO l = j + 1, n - 1
678  i = i + 1
679  aa = abs( a( i+j*lda ) )
680 * A(j,l)
681  work( l ) = work( l ) + aa
682  s = s + aa
683  END DO
684  work( j ) = work( j ) + s
685  END DO
686 * j=n
687  s = zero
688  DO i = 0, k - 2
689  aa = abs( a( i+j*lda ) )
690 * A(i,k-1)
691  work( i ) = work( i ) + aa
692  s = s + aa
693  END DO
694 * i=k-1
695  aa = abs( a( i+j*lda ) )
696 * A(k-1,k-1)
697  s = s + aa
698  work( i ) = work( i ) + s
699  VALUE = work( 0 )
700  DO i = 1, n-1
701  temp = work( i )
702  IF( VALUE .LT. temp .OR. sisnan( temp ) )
703  $ VALUE = temp
704  END DO
705  ELSE
706 * ilu=1
707  DO i = k, n - 1
708  work( i ) = zero
709  END DO
710 * j=0 is special :process col A(k:n-1,k)
711  s = abs( a( 0 ) )
712 * A(k,k)
713  DO i = 1, k - 1
714  aa = abs( a( i ) )
715 * A(k+i,k)
716  work( i+k ) = work( i+k ) + aa
717  s = s + aa
718  END DO
719  work( k ) = work( k ) + s
720  DO j = 1, k - 1
721 * process
722  s = zero
723  DO i = 0, j - 2
724  aa = abs( a( i+j*lda ) )
725 * A(j-1,i)
726  work( i ) = work( i ) + aa
727  s = s + aa
728  END DO
729  aa = abs( a( i+j*lda ) )
730 * i=j-1 so process of A(j-1,j-1)
731  s = s + aa
732  work( j-1 ) = s
733 * is initialised here
734  i = i + 1
735 * i=j process A(j+k,j+k)
736  aa = abs( a( i+j*lda ) )
737  s = aa
738  DO l = k + j + 1, n - 1
739  i = i + 1
740  aa = abs( a( i+j*lda ) )
741 * A(l,k+j)
742  s = s + aa
743  work( l ) = work( l ) + aa
744  END DO
745  work( k+j ) = work( k+j ) + s
746  END DO
747 * j=k is special :process col A(k,0:k-1)
748  s = zero
749  DO i = 0, k - 2
750  aa = abs( a( i+j*lda ) )
751 * A(k,i)
752  work( i ) = work( i ) + aa
753  s = s + aa
754  END DO
755 * i=k-1
756  aa = abs( a( i+j*lda ) )
757 * A(k-1,k-1)
758  s = s + aa
759  work( i ) = s
760 * done with col j=k+1
761  DO j = k + 1, n
762 * process col j-1 of A = A(j-1,0:k-1)
763  s = zero
764  DO i = 0, k - 1
765  aa = abs( a( i+j*lda ) )
766 * A(j-1,i)
767  work( i ) = work( i ) + aa
768  s = s + aa
769  END DO
770  work( j-1 ) = work( j-1 ) + s
771  END DO
772  VALUE = work( 0 )
773  DO i = 1, n-1
774  temp = work( i )
775  IF( VALUE .LT. temp .OR. sisnan( temp ) )
776  $ VALUE = temp
777  END DO
778  END IF
779  END IF
780  END IF
781  ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
782 *
783 * Find normF(A).
784 *
785  k = ( n+1 ) / 2
786  scale = zero
787  s = one
788  IF( noe.EQ.1 ) THEN
789 * n is odd
790  IF( ifm.EQ.1 ) THEN
791 * A is normal
792  IF( ilu.EQ.0 ) THEN
793 * A is upper
794  DO j = 0, k - 3
795  CALL slassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s )
796 * L at A(k,0)
797  END DO
798  DO j = 0, k - 1
799  CALL slassq( k+j-1, a( 0+j*lda ), 1, scale, s )
800 * trap U at A(0,0)
801  END DO
802  s = s + s
803 * double s for the off diagonal elements
804  CALL slassq( k-1, a( k ), lda+1, scale, s )
805 * tri L at A(k,0)
806  CALL slassq( k, a( k-1 ), lda+1, scale, s )
807 * tri U at A(k-1,0)
808  ELSE
809 * ilu=1 & A is lower
810  DO j = 0, k - 1
811  CALL slassq( n-j-1, a( j+1+j*lda ), 1, scale, s )
812 * trap L at A(0,0)
813  END DO
814  DO j = 0, k - 2
815  CALL slassq( j, a( 0+( 1+j )*lda ), 1, scale, s )
816 * U at A(0,1)
817  END DO
818  s = s + s
819 * double s for the off diagonal elements
820  CALL slassq( k, a( 0 ), lda+1, scale, s )
821 * tri L at A(0,0)
822  CALL slassq( k-1, a( 0+lda ), lda+1, scale, s )
823 * tri U at A(0,1)
824  END IF
825  ELSE
826 * A is xpose
827  IF( ilu.EQ.0 ) THEN
828 * A**T is upper
829  DO j = 1, k - 2
830  CALL slassq( j, a( 0+( k+j )*lda ), 1, scale, s )
831 * U at A(0,k)
832  END DO
833  DO j = 0, k - 2
834  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
835 * k by k-1 rect. at A(0,0)
836  END DO
837  DO j = 0, k - 2
838  CALL slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,
839  $ scale, s )
840 * L at A(0,k-1)
841  END DO
842  s = s + s
843 * double s for the off diagonal elements
844  CALL slassq( k-1, a( 0+k*lda ), lda+1, scale, s )
845 * tri U at A(0,k)
846  CALL slassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s )
847 * tri L at A(0,k-1)
848  ELSE
849 * A**T is lower
850  DO j = 1, k - 1
851  CALL slassq( j, a( 0+j*lda ), 1, scale, s )
852 * U at A(0,0)
853  END DO
854  DO j = k, n - 1
855  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
856 * k by k-1 rect. at A(0,k)
857  END DO
858  DO j = 0, k - 3
859  CALL slassq( k-j-2, a( j+2+j*lda ), 1, scale, s )
860 * L at A(1,0)
861  END DO
862  s = s + s
863 * double s for the off diagonal elements
864  CALL slassq( k, a( 0 ), lda+1, scale, s )
865 * tri U at A(0,0)
866  CALL slassq( k-1, a( 1 ), lda+1, scale, s )
867 * tri L at A(1,0)
868  END IF
869  END IF
870  ELSE
871 * n is even
872  IF( ifm.EQ.1 ) THEN
873 * A is normal
874  IF( ilu.EQ.0 ) THEN
875 * A is upper
876  DO j = 0, k - 2
877  CALL slassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s )
878 * L at A(k+1,0)
879  END DO
880  DO j = 0, k - 1
881  CALL slassq( k+j, a( 0+j*lda ), 1, scale, s )
882 * trap U at A(0,0)
883  END DO
884  s = s + s
885 * double s for the off diagonal elements
886  CALL slassq( k, a( k+1 ), lda+1, scale, s )
887 * tri L at A(k+1,0)
888  CALL slassq( k, a( k ), lda+1, scale, s )
889 * tri U at A(k,0)
890  ELSE
891 * ilu=1 & A is lower
892  DO j = 0, k - 1
893  CALL slassq( n-j-1, a( j+2+j*lda ), 1, scale, s )
894 * trap L at A(1,0)
895  END DO
896  DO j = 1, k - 1
897  CALL slassq( j, a( 0+j*lda ), 1, scale, s )
898 * U at A(0,0)
899  END DO
900  s = s + s
901 * double s for the off diagonal elements
902  CALL slassq( k, a( 1 ), lda+1, scale, s )
903 * tri L at A(1,0)
904  CALL slassq( k, a( 0 ), lda+1, scale, s )
905 * tri U at A(0,0)
906  END IF
907  ELSE
908 * A is xpose
909  IF( ilu.EQ.0 ) THEN
910 * A**T is upper
911  DO j = 1, k - 1
912  CALL slassq( j, a( 0+( k+1+j )*lda ), 1, scale, s )
913 * U at A(0,k+1)
914  END DO
915  DO j = 0, k - 1
916  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
917 * k by k rect. at A(0,0)
918  END DO
919  DO j = 0, k - 2
920  CALL slassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,
921  $ s )
922 * L at A(0,k)
923  END DO
924  s = s + s
925 * double s for the off diagonal elements
926  CALL slassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s )
927 * tri U at A(0,k+1)
928  CALL slassq( k, a( 0+k*lda ), lda+1, scale, s )
929 * tri L at A(0,k)
930  ELSE
931 * A**T is lower
932  DO j = 1, k - 1
933  CALL slassq( j, a( 0+( j+1 )*lda ), 1, scale, s )
934 * U at A(0,1)
935  END DO
936  DO j = k + 1, n
937  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
938 * k by k rect. at A(0,k+1)
939  END DO
940  DO j = 0, k - 2
941  CALL slassq( k-j-1, a( j+1+j*lda ), 1, scale, s )
942 * L at A(0,0)
943  END DO
944  s = s + s
945 * double s for the off diagonal elements
946  CALL slassq( k, a( lda ), lda+1, scale, s )
947 * tri L at A(0,1)
948  CALL slassq( k, a( 0 ), lda+1, scale, s )
949 * tri U at A(0,0)
950  END IF
951  END IF
952  END IF
953  VALUE = scale*sqrt( s )
954  END IF
955 *
956  slansf = VALUE
957  RETURN
958 *
959 * End of SLANSF
960 *
961  END
subroutine slassq(n, x, incx, scl, sumsq)
SLASSQ updates a sum of squares represented in scaled form.
Definition: slassq.f90:126
logical function sisnan(SIN)
SISNAN tests input for NaN.
Definition: sisnan.f:59
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
real function slansf(NORM, TRANSR, UPLO, N, A, WORK)
SLANSF
Definition: slansf.f:209