LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ slansf()

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.
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 208 of file slansf.f.

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 *
subroutine slassq(n, x, incx, scl, sumsq)
SLASSQ updates a sum of squares represented in scaled form.
Definition: slassq.f90:137
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
Here is the call graph for this function: