LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
real function slansf ( character  NORM,
character  TRANSR,
character  UPLO,
integer  N,
real, dimension( 0: * )  A,
real, dimension( 0: * )  WORK 
)

SLANSF

Download SLANSF + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 SLANSF returns the value of the one norm, or the Frobenius norm, or
 the infinity norm, or the element of largest absolute value of a
 real symmetric matrix A in RFP format.
Returns
SLANSF
    SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'
             (
             ( norm1(A),         NORM = '1', 'O' or 'o'
             (
             ( normI(A),         NORM = 'I' or 'i'
             (
             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'

 where  norm1  denotes the  one norm of a matrix (maximum column sum),
 normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
 normF  denotes the  Frobenius norm of a matrix (square root of sum of
 squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
Parameters
[in]NORM
          NORM is CHARACTER*1
          Specifies the value to be returned in SLANSF as described
          above.
[in]TRANSR
          TRANSR is CHARACTER*1
          Specifies whether the RFP format of A is normal or
          transposed format.
          = 'N':  RFP format is Normal;
          = 'T':  RFP format is Transpose.
[in]UPLO
          UPLO is CHARACTER*1
           On entry, UPLO specifies whether the RFP matrix A came from
           an upper or lower triangular matrix as follows:
           = 'U': RFP A came from an upper triangular matrix;
           = 'L': RFP A came from a lower triangular matrix.
[in]N
          N is INTEGER
          The order of the matrix A. N >= 0. When N = 0, SLANSF is
          set to zero.
[in]A
          A is REAL array, dimension ( N*(N+1)/2 );
          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
          part of the symmetric matrix A stored in RFP format. See the
          "Notes" below for more details.
          Unchanged on exit.
[out]WORK
          WORK is REAL array, dimension (MAX(1,LWORK)),
          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
          WORK is not referenced.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
September 2012
Further Details:
  We first consider Rectangular Full Packed (RFP) Format when N is
  even. We give an example where N = 6.

      AP is Upper             AP is Lower

   00 01 02 03 04 05       00
      11 12 13 14 15       10 11
         22 23 24 25       20 21 22
            33 34 35       30 31 32 33
               44 45       40 41 42 43 44
                  55       50 51 52 53 54 55


  Let TRANSR = 'N'. RFP holds AP as follows:
  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
  the transpose of the first three columns of AP upper.
  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
  the transpose of the last three columns of AP lower.
  This covers the case N even and TRANSR = 'N'.

         RFP A                   RFP A

        03 04 05                33 43 53
        13 14 15                00 44 54
        23 24 25                10 11 55
        33 34 35                20 21 22
        00 44 45                30 31 32
        01 11 55                40 41 42
        02 12 22                50 51 52

  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
  transpose of RFP A above. One therefore gets:


           RFP A                   RFP A

     03 13 23 33 00 01 02    33 00 10 20 30 40 50
     04 14 24 34 44 11 12    43 44 11 21 31 41 51
     05 15 25 35 45 55 22    53 54 55 22 32 42 52


  We then consider Rectangular Full Packed (RFP) Format when N is
  odd. We give an example where N = 5.

     AP is Upper                 AP is Lower

   00 01 02 03 04              00
      11 12 13 14              10 11
         22 23 24              20 21 22
            33 34              30 31 32 33
               44              40 41 42 43 44


  Let TRANSR = 'N'. RFP holds AP as follows:
  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
  the transpose of the first two columns of AP upper.
  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
  the transpose of the last two columns of AP lower.
  This covers the case N odd and TRANSR = 'N'.

         RFP A                   RFP A

        02 03 04                00 33 43
        12 13 14                10 11 44
        22 23 24                20 21 22
        00 33 34                30 31 32
        01 11 44                40 41 42

  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
  transpose of RFP A above. One therefore gets:

           RFP A                   RFP A

     02 12 22 00 01             00 10 20 30 40 50
     03 13 23 33 11             33 11 21 31 41 51
     04 14 24 34 44             43 44 22 32 42 52

Definition at line 211 of file slansf.f.

211 *
212 * -- LAPACK computational routine (version 3.4.2) --
213 * -- LAPACK is a software package provided by Univ. of Tennessee, --
214 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
215 * September 2012
216 *
217 * .. Scalar Arguments ..
218  CHARACTER norm, transr, uplo
219  INTEGER n
220 * ..
221 * .. Array Arguments ..
222  REAL a( 0: * ), work( 0: * )
223 * ..
224 *
225 * =====================================================================
226 *
227 * ..
228 * .. Parameters ..
229  REAL one, zero
230  parameter ( one = 1.0e+0, zero = 0.0e+0 )
231 * ..
232 * .. Local Scalars ..
233  INTEGER i, j, ifm, ilu, noe, n1, k, l, lda
234  REAL scale, s, VALUE, aa, temp
235 * ..
236 * .. External Functions ..
237  LOGICAL lsame, sisnan
238  EXTERNAL lsame, sisnan
239 * ..
240 * .. External Subroutines ..
241  EXTERNAL slassq
242 * ..
243 * .. Intrinsic Functions ..
244  INTRINSIC abs, sqrt
245 * ..
246 * .. Executable Statements ..
247 *
248  IF( n.EQ.0 ) THEN
249  slansf = zero
250  RETURN
251  ELSE IF( n.EQ.1 ) THEN
252  slansf = abs( a(0) )
253  RETURN
254  END IF
255 *
256 * set noe = 1 if n is odd. if n is even set noe=0
257 *
258  noe = 1
259  IF( mod( n, 2 ).EQ.0 )
260  $ noe = 0
261 *
262 * set ifm = 0 when form='T or 't' and 1 otherwise
263 *
264  ifm = 1
265  IF( lsame( transr, 'T' ) )
266  $ ifm = 0
267 *
268 * set ilu = 0 when uplo='U or 'u' and 1 otherwise
269 *
270  ilu = 1
271  IF( lsame( uplo, 'U' ) )
272  $ ilu = 0
273 *
274 * set lda = (n+1)/2 when ifm = 0
275 * set lda = n when ifm = 1 and noe = 1
276 * set lda = n+1 when ifm = 1 and noe = 0
277 *
278  IF( ifm.EQ.1 ) THEN
279  IF( noe.EQ.1 ) THEN
280  lda = n
281  ELSE
282 * noe=0
283  lda = n + 1
284  END IF
285  ELSE
286 * ifm=0
287  lda = ( n+1 ) / 2
288  END IF
289 *
290  IF( lsame( norm, 'M' ) ) THEN
291 *
292 * Find max(abs(A(i,j))).
293 *
294  k = ( n+1 ) / 2
295  VALUE = zero
296  IF( noe.EQ.1 ) THEN
297 * n is odd
298  IF( ifm.EQ.1 ) THEN
299 * A is n by k
300  DO j = 0, k - 1
301  DO i = 0, n - 1
302  temp = abs( a( i+j*lda ) )
303  IF( VALUE .LT. temp .OR. sisnan( temp ) )
304  $ VALUE = temp
305  END DO
306  END DO
307  ELSE
308 * xpose case; A is k by n
309  DO j = 0, n - 1
310  DO i = 0, k - 1
311  temp = abs( a( i+j*lda ) )
312  IF( VALUE .LT. temp .OR. sisnan( temp ) )
313  $ VALUE = temp
314  END DO
315  END DO
316  END IF
317  ELSE
318 * n is even
319  IF( ifm.EQ.1 ) THEN
320 * A is n+1 by k
321  DO j = 0, k - 1
322  DO i = 0, n
323  temp = abs( a( i+j*lda ) )
324  IF( VALUE .LT. temp .OR. sisnan( temp ) )
325  $ VALUE = temp
326  END DO
327  END DO
328  ELSE
329 * xpose case; A is k by n+1
330  DO j = 0, n
331  DO i = 0, k - 1
332  temp = abs( a( i+j*lda ) )
333  IF( VALUE .LT. temp .OR. sisnan( temp ) )
334  $ VALUE = temp
335  END DO
336  END DO
337  END IF
338  END IF
339  ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR.
340  $ ( norm.EQ.'1' ) ) THEN
341 *
342 * Find normI(A) ( = norm1(A), since A is symmetric).
343 *
344  IF( ifm.EQ.1 ) THEN
345  k = n / 2
346  IF( noe.EQ.1 ) THEN
347 * n is odd
348  IF( ilu.EQ.0 ) THEN
349  DO i = 0, k - 1
350  work( i ) = zero
351  END DO
352  DO j = 0, k
353  s = zero
354  DO i = 0, k + j - 1
355  aa = abs( a( i+j*lda ) )
356 * -> A(i,j+k)
357  s = s + aa
358  work( i ) = work( i ) + aa
359  END DO
360  aa = abs( a( i+j*lda ) )
361 * -> A(j+k,j+k)
362  work( j+k ) = s + aa
363  IF( i.EQ.k+k )
364  $ GO TO 10
365  i = i + 1
366  aa = abs( a( i+j*lda ) )
367 * -> A(j,j)
368  work( j ) = work( j ) + aa
369  s = zero
370  DO l = j + 1, k - 1
371  i = i + 1
372  aa = abs( a( i+j*lda ) )
373 * -> A(l,j)
374  s = s + aa
375  work( l ) = work( l ) + aa
376  END DO
377  work( j ) = work( j ) + s
378  END DO
379  10 CONTINUE
380  VALUE = work( 0 )
381  DO i = 1, n-1
382  temp = work( i )
383  IF( VALUE .LT. temp .OR. sisnan( temp ) )
384  $ VALUE = temp
385  END DO
386  ELSE
387 * ilu = 1
388  k = k + 1
389 * k=(n+1)/2 for n odd and ilu=1
390  DO i = k, n - 1
391  work( i ) = zero
392  END DO
393  DO j = k - 1, 0, -1
394  s = zero
395  DO i = 0, j - 2
396  aa = abs( a( i+j*lda ) )
397 * -> A(j+k,i+k)
398  s = s + aa
399  work( i+k ) = work( i+k ) + aa
400  END DO
401  IF( j.GT.0 ) THEN
402  aa = abs( a( i+j*lda ) )
403 * -> A(j+k,j+k)
404  s = s + aa
405  work( i+k ) = work( i+k ) + s
406 * i=j
407  i = i + 1
408  END IF
409  aa = abs( a( i+j*lda ) )
410 * -> A(j,j)
411  work( j ) = aa
412  s = zero
413  DO l = j + 1, n - 1
414  i = i + 1
415  aa = abs( a( i+j*lda ) )
416 * -> A(l,j)
417  s = s + aa
418  work( l ) = work( l ) + aa
419  END DO
420  work( j ) = work( j ) + s
421  END DO
422  VALUE = work( 0 )
423  DO i = 1, n-1
424  temp = work( i )
425  IF( VALUE .LT. temp .OR. sisnan( temp ) )
426  $ VALUE = temp
427  END DO
428  END IF
429  ELSE
430 * n is even
431  IF( ilu.EQ.0 ) THEN
432  DO i = 0, k - 1
433  work( i ) = zero
434  END DO
435  DO j = 0, k - 1
436  s = zero
437  DO i = 0, k + j - 1
438  aa = abs( a( i+j*lda ) )
439 * -> A(i,j+k)
440  s = s + aa
441  work( i ) = work( i ) + aa
442  END DO
443  aa = abs( a( i+j*lda ) )
444 * -> A(j+k,j+k)
445  work( j+k ) = s + aa
446  i = i + 1
447  aa = abs( a( i+j*lda ) )
448 * -> A(j,j)
449  work( j ) = work( j ) + aa
450  s = zero
451  DO l = j + 1, k - 1
452  i = i + 1
453  aa = abs( a( i+j*lda ) )
454 * -> A(l,j)
455  s = s + aa
456  work( l ) = work( l ) + aa
457  END DO
458  work( j ) = work( j ) + s
459  END DO
460  VALUE = work( 0 )
461  DO i = 1, n-1
462  temp = work( i )
463  IF( VALUE .LT. temp .OR. sisnan( temp ) )
464  $ VALUE = temp
465  END DO
466  ELSE
467 * ilu = 1
468  DO i = k, n - 1
469  work( i ) = zero
470  END DO
471  DO j = k - 1, 0, -1
472  s = zero
473  DO i = 0, j - 1
474  aa = abs( a( i+j*lda ) )
475 * -> A(j+k,i+k)
476  s = s + aa
477  work( i+k ) = work( i+k ) + aa
478  END DO
479  aa = abs( a( i+j*lda ) )
480 * -> A(j+k,j+k)
481  s = s + aa
482  work( i+k ) = work( i+k ) + s
483 * i=j
484  i = i + 1
485  aa = abs( a( i+j*lda ) )
486 * -> A(j,j)
487  work( j ) = aa
488  s = zero
489  DO l = j + 1, n - 1
490  i = i + 1
491  aa = abs( a( i+j*lda ) )
492 * -> A(l,j)
493  s = s + aa
494  work( l ) = work( l ) + aa
495  END DO
496  work( j ) = work( j ) + s
497  END DO
498  VALUE = work( 0 )
499  DO i = 1, n-1
500  temp = work( i )
501  IF( VALUE .LT. temp .OR. sisnan( temp ) )
502  $ VALUE = temp
503  END DO
504  END IF
505  END IF
506  ELSE
507 * ifm=0
508  k = n / 2
509  IF( noe.EQ.1 ) THEN
510 * n is odd
511  IF( ilu.EQ.0 ) THEN
512  n1 = k
513 * n/2
514  k = k + 1
515 * k is the row size and lda
516  DO i = n1, n - 1
517  work( i ) = zero
518  END DO
519  DO j = 0, n1 - 1
520  s = zero
521  DO i = 0, k - 1
522  aa = abs( a( i+j*lda ) )
523 * A(j,n1+i)
524  work( i+n1 ) = work( i+n1 ) + aa
525  s = s + aa
526  END DO
527  work( j ) = s
528  END DO
529 * j=n1=k-1 is special
530  s = abs( a( 0+j*lda ) )
531 * A(k-1,k-1)
532  DO i = 1, k - 1
533  aa = abs( a( i+j*lda ) )
534 * A(k-1,i+n1)
535  work( i+n1 ) = work( i+n1 ) + aa
536  s = s + aa
537  END DO
538  work( j ) = work( j ) + s
539  DO j = k, n - 1
540  s = zero
541  DO i = 0, j - k - 1
542  aa = abs( a( i+j*lda ) )
543 * A(i,j-k)
544  work( i ) = work( i ) + aa
545  s = s + aa
546  END DO
547 * i=j-k
548  aa = abs( a( i+j*lda ) )
549 * A(j-k,j-k)
550  s = s + aa
551  work( j-k ) = work( j-k ) + s
552  i = i + 1
553  s = abs( a( i+j*lda ) )
554 * A(j,j)
555  DO l = j + 1, n - 1
556  i = i + 1
557  aa = abs( a( i+j*lda ) )
558 * A(j,l)
559  work( l ) = work( l ) + aa
560  s = s + aa
561  END DO
562  work( j ) = work( j ) + s
563  END DO
564  VALUE = work( 0 )
565  DO i = 1, n-1
566  temp = work( i )
567  IF( VALUE .LT. temp .OR. sisnan( temp ) )
568  $ VALUE = temp
569  END DO
570  ELSE
571 * ilu=1
572  k = k + 1
573 * k=(n+1)/2 for n odd and ilu=1
574  DO i = k, n - 1
575  work( i ) = zero
576  END DO
577  DO j = 0, k - 2
578 * process
579  s = zero
580  DO i = 0, j - 1
581  aa = abs( a( i+j*lda ) )
582 * A(j,i)
583  work( i ) = work( i ) + aa
584  s = s + aa
585  END DO
586  aa = abs( a( i+j*lda ) )
587 * i=j so process of A(j,j)
588  s = s + aa
589  work( j ) = s
590 * is initialised here
591  i = i + 1
592 * i=j process A(j+k,j+k)
593  aa = abs( a( i+j*lda ) )
594  s = aa
595  DO l = k + j + 1, n - 1
596  i = i + 1
597  aa = abs( a( i+j*lda ) )
598 * A(l,k+j)
599  s = s + aa
600  work( l ) = work( l ) + aa
601  END DO
602  work( k+j ) = work( k+j ) + s
603  END DO
604 * j=k-1 is special :process col A(k-1,0:k-1)
605  s = zero
606  DO i = 0, k - 2
607  aa = abs( a( i+j*lda ) )
608 * A(k,i)
609  work( i ) = work( i ) + aa
610  s = s + aa
611  END DO
612 * i=k-1
613  aa = abs( a( i+j*lda ) )
614 * A(k-1,k-1)
615  s = s + aa
616  work( i ) = s
617 * done with col j=k+1
618  DO j = k, n - 1
619 * process col j of A = A(j,0:k-1)
620  s = zero
621  DO i = 0, k - 1
622  aa = abs( a( i+j*lda ) )
623 * A(j,i)
624  work( i ) = work( i ) + aa
625  s = s + aa
626  END DO
627  work( j ) = work( j ) + s
628  END DO
629  VALUE = work( 0 )
630  DO i = 1, n-1
631  temp = work( i )
632  IF( VALUE .LT. temp .OR. sisnan( temp ) )
633  $ VALUE = temp
634  END DO
635  END IF
636  ELSE
637 * n is even
638  IF( ilu.EQ.0 ) THEN
639  DO i = k, n - 1
640  work( i ) = zero
641  END DO
642  DO j = 0, k - 1
643  s = zero
644  DO i = 0, k - 1
645  aa = abs( a( i+j*lda ) )
646 * A(j,i+k)
647  work( i+k ) = work( i+k ) + aa
648  s = s + aa
649  END DO
650  work( j ) = s
651  END DO
652 * j=k
653  aa = abs( a( 0+j*lda ) )
654 * A(k,k)
655  s = aa
656  DO i = 1, k - 1
657  aa = abs( a( i+j*lda ) )
658 * A(k,k+i)
659  work( i+k ) = work( i+k ) + aa
660  s = s + aa
661  END DO
662  work( j ) = work( j ) + s
663  DO j = k + 1, n - 1
664  s = zero
665  DO i = 0, j - 2 - k
666  aa = abs( a( i+j*lda ) )
667 * A(i,j-k-1)
668  work( i ) = work( i ) + aa
669  s = s + aa
670  END DO
671 * i=j-1-k
672  aa = abs( a( i+j*lda ) )
673 * A(j-k-1,j-k-1)
674  s = s + aa
675  work( j-k-1 ) = work( j-k-1 ) + s
676  i = i + 1
677  aa = abs( a( i+j*lda ) )
678 * A(j,j)
679  s = aa
680  DO l = j + 1, n - 1
681  i = i + 1
682  aa = abs( a( i+j*lda ) )
683 * A(j,l)
684  work( l ) = work( l ) + aa
685  s = s + aa
686  END DO
687  work( j ) = work( j ) + s
688  END DO
689 * j=n
690  s = zero
691  DO i = 0, k - 2
692  aa = abs( a( i+j*lda ) )
693 * A(i,k-1)
694  work( i ) = work( i ) + aa
695  s = s + aa
696  END DO
697 * i=k-1
698  aa = abs( a( i+j*lda ) )
699 * A(k-1,k-1)
700  s = s + aa
701  work( i ) = work( i ) + s
702  VALUE = work( 0 )
703  DO i = 1, n-1
704  temp = work( i )
705  IF( VALUE .LT. temp .OR. sisnan( temp ) )
706  $ VALUE = temp
707  END DO
708  ELSE
709 * ilu=1
710  DO i = k, n - 1
711  work( i ) = zero
712  END DO
713 * j=0 is special :process col A(k:n-1,k)
714  s = abs( a( 0 ) )
715 * A(k,k)
716  DO i = 1, k - 1
717  aa = abs( a( i ) )
718 * A(k+i,k)
719  work( i+k ) = work( i+k ) + aa
720  s = s + aa
721  END DO
722  work( k ) = work( k ) + s
723  DO j = 1, k - 1
724 * process
725  s = zero
726  DO i = 0, j - 2
727  aa = abs( a( i+j*lda ) )
728 * A(j-1,i)
729  work( i ) = work( i ) + aa
730  s = s + aa
731  END DO
732  aa = abs( a( i+j*lda ) )
733 * i=j-1 so process of A(j-1,j-1)
734  s = s + aa
735  work( j-1 ) = s
736 * is initialised here
737  i = i + 1
738 * i=j process A(j+k,j+k)
739  aa = abs( a( i+j*lda ) )
740  s = aa
741  DO l = k + j + 1, n - 1
742  i = i + 1
743  aa = abs( a( i+j*lda ) )
744 * A(l,k+j)
745  s = s + aa
746  work( l ) = work( l ) + aa
747  END DO
748  work( k+j ) = work( k+j ) + s
749  END DO
750 * j=k is special :process col A(k,0:k-1)
751  s = zero
752  DO i = 0, k - 2
753  aa = abs( a( i+j*lda ) )
754 * A(k,i)
755  work( i ) = work( i ) + aa
756  s = s + aa
757  END DO
758 * i=k-1
759  aa = abs( a( i+j*lda ) )
760 * A(k-1,k-1)
761  s = s + aa
762  work( i ) = s
763 * done with col j=k+1
764  DO j = k + 1, n
765 * process col j-1 of A = A(j-1,0:k-1)
766  s = zero
767  DO i = 0, k - 1
768  aa = abs( a( i+j*lda ) )
769 * A(j-1,i)
770  work( i ) = work( i ) + aa
771  s = s + aa
772  END DO
773  work( j-1 ) = work( j-1 ) + s
774  END DO
775  VALUE = work( 0 )
776  DO i = 1, n-1
777  temp = work( i )
778  IF( VALUE .LT. temp .OR. sisnan( temp ) )
779  $ VALUE = temp
780  END DO
781  END IF
782  END IF
783  END IF
784  ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
785 *
786 * Find normF(A).
787 *
788  k = ( n+1 ) / 2
789  scale = zero
790  s = one
791  IF( noe.EQ.1 ) THEN
792 * n is odd
793  IF( ifm.EQ.1 ) THEN
794 * A is normal
795  IF( ilu.EQ.0 ) THEN
796 * A is upper
797  DO j = 0, k - 3
798  CALL slassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s )
799 * L at A(k,0)
800  END DO
801  DO j = 0, k - 1
802  CALL slassq( k+j-1, a( 0+j*lda ), 1, scale, s )
803 * trap U at A(0,0)
804  END DO
805  s = s + s
806 * double s for the off diagonal elements
807  CALL slassq( k-1, a( k ), lda+1, scale, s )
808 * tri L at A(k,0)
809  CALL slassq( k, a( k-1 ), lda+1, scale, s )
810 * tri U at A(k-1,0)
811  ELSE
812 * ilu=1 & A is lower
813  DO j = 0, k - 1
814  CALL slassq( n-j-1, a( j+1+j*lda ), 1, scale, s )
815 * trap L at A(0,0)
816  END DO
817  DO j = 0, k - 2
818  CALL slassq( j, a( 0+( 1+j )*lda ), 1, scale, s )
819 * U at A(0,1)
820  END DO
821  s = s + s
822 * double s for the off diagonal elements
823  CALL slassq( k, a( 0 ), lda+1, scale, s )
824 * tri L at A(0,0)
825  CALL slassq( k-1, a( 0+lda ), lda+1, scale, s )
826 * tri U at A(0,1)
827  END IF
828  ELSE
829 * A is xpose
830  IF( ilu.EQ.0 ) THEN
831 * A**T is upper
832  DO j = 1, k - 2
833  CALL slassq( j, a( 0+( k+j )*lda ), 1, scale, s )
834 * U at A(0,k)
835  END DO
836  DO j = 0, k - 2
837  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
838 * k by k-1 rect. at A(0,0)
839  END DO
840  DO j = 0, k - 2
841  CALL slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,
842  $ scale, s )
843 * L at A(0,k-1)
844  END DO
845  s = s + s
846 * double s for the off diagonal elements
847  CALL slassq( k-1, a( 0+k*lda ), lda+1, scale, s )
848 * tri U at A(0,k)
849  CALL slassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s )
850 * tri L at A(0,k-1)
851  ELSE
852 * A**T is lower
853  DO j = 1, k - 1
854  CALL slassq( j, a( 0+j*lda ), 1, scale, s )
855 * U at A(0,0)
856  END DO
857  DO j = k, n - 1
858  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
859 * k by k-1 rect. at A(0,k)
860  END DO
861  DO j = 0, k - 3
862  CALL slassq( k-j-2, a( j+2+j*lda ), 1, scale, s )
863 * L at A(1,0)
864  END DO
865  s = s + s
866 * double s for the off diagonal elements
867  CALL slassq( k, a( 0 ), lda+1, scale, s )
868 * tri U at A(0,0)
869  CALL slassq( k-1, a( 1 ), lda+1, scale, s )
870 * tri L at A(1,0)
871  END IF
872  END IF
873  ELSE
874 * n is even
875  IF( ifm.EQ.1 ) THEN
876 * A is normal
877  IF( ilu.EQ.0 ) THEN
878 * A is upper
879  DO j = 0, k - 2
880  CALL slassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s )
881 * L at A(k+1,0)
882  END DO
883  DO j = 0, k - 1
884  CALL slassq( k+j, a( 0+j*lda ), 1, scale, s )
885 * trap U at A(0,0)
886  END DO
887  s = s + s
888 * double s for the off diagonal elements
889  CALL slassq( k, a( k+1 ), lda+1, scale, s )
890 * tri L at A(k+1,0)
891  CALL slassq( k, a( k ), lda+1, scale, s )
892 * tri U at A(k,0)
893  ELSE
894 * ilu=1 & A is lower
895  DO j = 0, k - 1
896  CALL slassq( n-j-1, a( j+2+j*lda ), 1, scale, s )
897 * trap L at A(1,0)
898  END DO
899  DO j = 1, k - 1
900  CALL slassq( j, a( 0+j*lda ), 1, scale, s )
901 * U at A(0,0)
902  END DO
903  s = s + s
904 * double s for the off diagonal elements
905  CALL slassq( k, a( 1 ), lda+1, scale, s )
906 * tri L at A(1,0)
907  CALL slassq( k, a( 0 ), lda+1, scale, s )
908 * tri U at A(0,0)
909  END IF
910  ELSE
911 * A is xpose
912  IF( ilu.EQ.0 ) THEN
913 * A**T is upper
914  DO j = 1, k - 1
915  CALL slassq( j, a( 0+( k+1+j )*lda ), 1, scale, s )
916 * U at A(0,k+1)
917  END DO
918  DO j = 0, k - 1
919  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
920 * k by k rect. at A(0,0)
921  END DO
922  DO j = 0, k - 2
923  CALL slassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,
924  $ s )
925 * L at A(0,k)
926  END DO
927  s = s + s
928 * double s for the off diagonal elements
929  CALL slassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s )
930 * tri U at A(0,k+1)
931  CALL slassq( k, a( 0+k*lda ), lda+1, scale, s )
932 * tri L at A(0,k)
933  ELSE
934 * A**T is lower
935  DO j = 1, k - 1
936  CALL slassq( j, a( 0+( j+1 )*lda ), 1, scale, s )
937 * U at A(0,1)
938  END DO
939  DO j = k + 1, n
940  CALL slassq( k, a( 0+j*lda ), 1, scale, s )
941 * k by k rect. at A(0,k+1)
942  END DO
943  DO j = 0, k - 2
944  CALL slassq( k-j-1, a( j+1+j*lda ), 1, scale, s )
945 * L at A(0,0)
946  END DO
947  s = s + s
948 * double s for the off diagonal elements
949  CALL slassq( k, a( lda ), lda+1, scale, s )
950 * tri L at A(0,1)
951  CALL slassq( k, a( 0 ), lda+1, scale, s )
952 * tri U at A(0,0)
953  END IF
954  END IF
955  END IF
956  VALUE = scale*sqrt( s )
957  END IF
958 *
959  slansf = VALUE
960  RETURN
961 *
962 * End of SLANSF
963 *
subroutine slassq(N, X, INCX, SCALE, SUMSQ)
SLASSQ updates a sum of squares represented in scaled form.
Definition: slassq.f:105
logical function sisnan(SIN)
SISNAN tests input for NaN.
Definition: sisnan.f:61
real function slansf(NORM, TRANSR, UPLO, N, A, WORK)
SLANSF
Definition: slansf.f:211
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55

Here is the call graph for this function: