SRC/slantp.f

   1 *> \brief \b SLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form.
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download SLANTP + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slantp.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slantp.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slantp.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       REAL             FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       CHARACTER          DIAG, NORM, UPLO
  25 *       INTEGER            N
  26 *       ..
  27 *       .. Array Arguments ..
  28 *       REAL               AP( * ), WORK( * )
  29 *       ..
  30 *
  31 *
  32 *> \par Purpose:
  33 *  =============
  34 *>
  35 *> \verbatim
  36 *>
  37 *> SLANTP  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 *> triangular matrix A, supplied in packed form.
  40 *> \endverbatim
  41 *>
  42 *> \return SLANTP
  43 *> \verbatim
  44 *>
  45 *>    SLANTP = ( 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 consistent 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 SLANTP as described
  66 *>          above.
  67 *> \endverbatim
  68 *>
  69 *> \param[in] UPLO
  70 *> \verbatim
  71 *>          UPLO is CHARACTER*1
  72 *>          Specifies whether the matrix A is upper or lower triangular.
  73 *>          = 'U':  Upper triangular
  74 *>          = 'L':  Lower triangular
  75 *> \endverbatim
  76 *>
  77 *> \param[in] DIAG
  78 *> \verbatim
  79 *>          DIAG is CHARACTER*1
  80 *>          Specifies whether or not the matrix A is unit triangular.
  81 *>          = 'N':  Non-unit triangular
  82 *>          = 'U':  Unit triangular
  83 *> \endverbatim
  84 *>
  85 *> \param[in] N
  86 *> \verbatim
  87 *>          N is INTEGER
  88 *>          The order of the matrix A.  N >= 0.  When N = 0, SLANTP is
  89 *>          set to zero.
  90 *> \endverbatim
  91 *>
  92 *> \param[in] AP
  93 *> \verbatim
  94 *>          AP is REAL array, dimension (N*(N+1)/2)
  95 *>          The upper or lower triangular matrix A, packed columnwise in
  96 *>          a linear array.  The j-th column of A is stored in the array
  97 *>          AP as follows:
  98 *>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
  99 *>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
 100 *>          Note that when DIAG = 'U', the elements of the array AP
 101 *>          corresponding to the diagonal elements of the matrix A are
 102 *>          not referenced, but are assumed to be one.
 103 *> \endverbatim
 104 *>
 105 *> \param[out] WORK
 106 *> \verbatim
 107 *>          WORK is REAL array, dimension (MAX(1,LWORK)),
 108 *>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
 109 *>          referenced.
 110 *> \endverbatim
 111 *
 112 *  Authors:
 113 *  ========
 114 *
 115 *> \author Univ. of Tennessee
 116 *> \author Univ. of California Berkeley
 117 *> \author Univ. of Colorado Denver
 118 *> \author NAG Ltd.
 119 *
 120 *> \date September 2012
 121 *
 122 *> \ingroup realOTHERauxiliary
 123 *
 124 *  =====================================================================
 125       REAL             FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )
 126 *
 127 *  -- LAPACK auxiliary routine (version 3.4.2) --
 128 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 129 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 130 *     September 2012
 131 *
 132 *     .. Scalar Arguments ..
 133       CHARACTER          DIAG, NORM, UPLO
 134       INTEGER            N
 135 *     ..
 136 *     .. Array Arguments ..
 137       REAL               AP( * ), WORK( * )
 138 *     ..
 139 *
 140 * =====================================================================
 141 *
 142 *     .. Parameters ..
 143       REAL               ONE, ZERO
 144       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
 145 *     ..
 146 *     .. Local Scalars ..
 147       LOGICAL            UDIAG
 148       INTEGER            I, J, K
 149       REAL               SCALE, SUM, VALUE
 150 *     ..
 151 *     .. External Subroutines ..
 152       EXTERNAL           SLASSQ
 153 *     ..
 154 *     .. External Functions ..
 155       LOGICAL            LSAME, SISNAN
 156       EXTERNAL           LSAME, SISNAN
 157 *     ..
 158 *     .. Intrinsic Functions ..
 159       INTRINSIC          ABS, SQRT
 160 *     ..
 161 *     .. Executable Statements ..
 162 *
 163       IF( N.EQ.0 ) THEN
 164          VALUE = ZERO
 165       ELSE IF( LSAME( NORM, 'M' ) ) THEN
 166 *
 167 *        Find max(abs(A(i,j))).
 168 *
 169          K = 1
 170          IF( LSAME( DIAG, 'U' ) ) THEN
 171             VALUE = ONE
 172             IF( LSAME( UPLO, 'U' ) ) THEN
 173                DO 20 J = 1, N
 174                   DO 10 I = K, K + J - 2
 175                      SUM = ABS( AP( I ) )
 176                      IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
 177    10             CONTINUE
 178                   K = K + J
 179    20          CONTINUE
 180             ELSE
 181                DO 40 J = 1, N
 182                   DO 30 I = K + 1, K + N - J
 183                      SUM = ABS( AP( I ) )
 184                      IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
 185    30             CONTINUE
 186                   K = K + N - J + 1
 187    40          CONTINUE
 188             END IF
 189          ELSE
 190             VALUE = ZERO
 191             IF( LSAME( UPLO, 'U' ) ) THEN
 192                DO 60 J = 1, N
 193                   DO 50 I = K, K + J - 1
 194                      SUM = ABS( AP( I ) )
 195                      IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
 196    50             CONTINUE
 197                   K = K + J
 198    60          CONTINUE
 199             ELSE
 200                DO 80 J = 1, N
 201                   DO 70 I = K, K + N - J
 202                      SUM = ABS( AP( I ) )
 203                      IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
 204    70             CONTINUE
 205                   K = K + N - J + 1
 206    80          CONTINUE
 207             END IF
 208          END IF
 209       ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
 210 *
 211 *        Find norm1(A).
 212 *
 213          VALUE = ZERO
 214          K = 1
 215          UDIAG = LSAME( DIAG, 'U' )
 216          IF( LSAME( UPLO, 'U' ) ) THEN
 217             DO 110 J = 1, N
 218                IF( UDIAG ) THEN
 219                   SUM = ONE
 220                   DO 90 I = K, K + J - 2
 221                      SUM = SUM + ABS( AP( I ) )
 222    90             CONTINUE
 223                ELSE
 224                   SUM = ZERO
 225                   DO 100 I = K, K + J - 1
 226                      SUM = SUM + ABS( AP( I ) )
 227   100             CONTINUE
 228                END IF
 229                K = K + J
 230                IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
 231   110       CONTINUE
 232          ELSE
 233             DO 140 J = 1, N
 234                IF( UDIAG ) THEN
 235                   SUM = ONE
 236                   DO 120 I = K + 1, K + N - J
 237                      SUM = SUM + ABS( AP( I ) )
 238   120             CONTINUE
 239                ELSE
 240                   SUM = ZERO
 241                   DO 130 I = K, K + N - J
 242                      SUM = SUM + ABS( AP( I ) )
 243   130             CONTINUE
 244                END IF
 245                K = K + N - J + 1
 246                IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
 247   140       CONTINUE
 248          END IF
 249       ELSE IF( LSAME( NORM, 'I' ) ) THEN
 250 *
 251 *        Find normI(A).
 252 *
 253          K = 1
 254          IF( LSAME( UPLO, 'U' ) ) THEN
 255             IF( LSAME( DIAG, 'U' ) ) THEN
 256                DO 150 I = 1, N
 257                   WORK( I ) = ONE
 258   150          CONTINUE
 259                DO 170 J = 1, N
 260                   DO 160 I = 1, J - 1
 261                      WORK( I ) = WORK( I ) + ABS( AP( K ) )
 262                      K = K + 1
 263   160             CONTINUE
 264                   K = K + 1
 265   170          CONTINUE
 266             ELSE
 267                DO 180 I = 1, N
 268                   WORK( I ) = ZERO
 269   180          CONTINUE
 270                DO 200 J = 1, N
 271                   DO 190 I = 1, J
 272                      WORK( I ) = WORK( I ) + ABS( AP( K ) )
 273                      K = K + 1
 274   190             CONTINUE
 275   200          CONTINUE
 276             END IF
 277          ELSE
 278             IF( LSAME( DIAG, 'U' ) ) THEN
 279                DO 210 I = 1, N
 280                   WORK( I ) = ONE
 281   210          CONTINUE
 282                DO 230 J = 1, N
 283                   K = K + 1
 284                   DO 220 I = J + 1, N
 285                      WORK( I ) = WORK( I ) + ABS( AP( K ) )
 286                      K = K + 1
 287   220             CONTINUE
 288   230          CONTINUE
 289             ELSE
 290                DO 240 I = 1, N
 291                   WORK( I ) = ZERO
 292   240          CONTINUE
 293                DO 260 J = 1, N
 294                   DO 250 I = J, N
 295                      WORK( I ) = WORK( I ) + ABS( AP( K ) )
 296                      K = K + 1
 297   250             CONTINUE
 298   260          CONTINUE
 299             END IF
 300          END IF
 301          VALUE = ZERO
 302          DO 270 I = 1, N
 303             SUM = WORK( I )
 304             IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
 305   270    CONTINUE
 306       ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
 307 *
 308 *        Find normF(A).
 309 *
 310          IF( LSAME( UPLO, 'U' ) ) THEN
 311             IF( LSAME( DIAG, 'U' ) ) THEN
 312                SCALE = ONE
 313                SUM = N
 314                K = 2
 315                DO 280 J = 2, N
 316                   CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM )
 317                   K = K + J
 318   280          CONTINUE
 319             ELSE
 320                SCALE = ZERO
 321                SUM = ONE
 322                K = 1
 323                DO 290 J = 1, N
 324                   CALL SLASSQ( J, AP( K ), 1, SCALE, SUM )
 325                   K = K + J
 326   290          CONTINUE
 327             END IF
 328          ELSE
 329             IF( LSAME( DIAG, 'U' ) ) THEN
 330                SCALE = ONE
 331                SUM = N
 332                K = 2
 333                DO 300 J = 1, N - 1
 334                   CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM )
 335                   K = K + N - J + 1
 336   300          CONTINUE
 337             ELSE
 338                SCALE = ZERO
 339                SUM = ONE
 340                K = 1
 341                DO 310 J = 1, N
 342                   CALL SLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
 343                   K = K + N - J + 1
 344   310          CONTINUE
 345             END IF
 346          END IF
 347          VALUE = SCALE*SQRT( SUM )
 348       END IF
 349 *
 350       SLANTP = VALUE
 351       RETURN
 352 *
 353 *     End of SLANTP
 354 *
 355       END