001:       REAL             FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
002:      $                 WORK )
003: *
004: *  -- LAPACK auxiliary routine (version 3.2) --
005: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
006: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
007: *     November 2006
008: *
009: *     .. Scalar Arguments ..
010:       CHARACTER          DIAG, NORM, UPLO
011:       INTEGER            LDA, M, N
012: *     ..
013: *     .. Array Arguments ..
014:       REAL               A( LDA, * ), WORK( * )
015: *     ..
016: *
017: *  Purpose
018: *  =======
019: *
020: *  SLANTR  returns the value of the one norm,  or the Frobenius norm, or
021: *  the  infinity norm,  or the  element of  largest absolute value  of a
022: *  trapezoidal or triangular matrix A.
023: *
024: *  Description
025: *  ===========
026: *
027: *  SLANTR returns the value
028: *
029: *     SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
030: *              (
031: *              ( norm1(A),         NORM = '1', 'O' or 'o'
032: *              (
033: *              ( normI(A),         NORM = 'I' or 'i'
034: *              (
035: *              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
036: *
037: *  where  norm1  denotes the  one norm of a matrix (maximum column sum),
038: *  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
039: *  normF  denotes the  Frobenius norm of a matrix (square root of sum of
040: *  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
041: *
042: *  Arguments
043: *  =========
044: *
045: *  NORM    (input) CHARACTER*1
046: *          Specifies the value to be returned in SLANTR as described
047: *          above.
048: *
049: *  UPLO    (input) CHARACTER*1
050: *          Specifies whether the matrix A is upper or lower trapezoidal.
051: *          = 'U':  Upper trapezoidal
052: *          = 'L':  Lower trapezoidal
053: *          Note that A is triangular instead of trapezoidal if M = N.
054: *
055: *  DIAG    (input) CHARACTER*1
056: *          Specifies whether or not the matrix A has unit diagonal.
057: *          = 'N':  Non-unit diagonal
058: *          = 'U':  Unit diagonal
059: *
060: *  M       (input) INTEGER
061: *          The number of rows of the matrix A.  M >= 0, and if
062: *          UPLO = 'U', M <= N.  When M = 0, SLANTR is set to zero.
063: *
064: *  N       (input) INTEGER
065: *          The number of columns of the matrix A.  N >= 0, and if
066: *          UPLO = 'L', N <= M.  When N = 0, SLANTR is set to zero.
067: *
068: *  A       (input) REAL array, dimension (LDA,N)
069: *          The trapezoidal matrix A (A is triangular if M = N).
070: *          If UPLO = 'U', the leading m by n upper trapezoidal part of
071: *          the array A contains the upper trapezoidal matrix, and the
072: *          strictly lower triangular part of A is not referenced.
073: *          If UPLO = 'L', the leading m by n lower trapezoidal part of
074: *          the array A contains the lower trapezoidal matrix, and the
075: *          strictly upper triangular part of A is not referenced.  Note
076: *          that when DIAG = 'U', the diagonal elements of A are not
077: *          referenced and are assumed to be one.
078: *
079: *  LDA     (input) INTEGER
080: *          The leading dimension of the array A.  LDA >= max(M,1).
081: *
082: *  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
083: *          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
084: *          referenced.
085: *
086: * =====================================================================
087: *
088: *     .. Parameters ..
089:       REAL               ONE, ZERO
090:       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
091: *     ..
092: *     .. Local Scalars ..
093:       LOGICAL            UDIAG
094:       INTEGER            I, J
095:       REAL               SCALE, SUM, VALUE
096: *     ..
097: *     .. External Subroutines ..
098:       EXTERNAL           SLASSQ
099: *     ..
100: *     .. External Functions ..
101:       LOGICAL            LSAME
102:       EXTERNAL           LSAME
103: *     ..
104: *     .. Intrinsic Functions ..
105:       INTRINSIC          ABS, MAX, MIN, SQRT
106: *     ..
107: *     .. Executable Statements ..
108: *
109:       IF( MIN( M, N ).EQ.0 ) THEN
110:          VALUE = ZERO
111:       ELSE IF( LSAME( NORM, 'M' ) ) THEN
112: *
113: *        Find max(abs(A(i,j))).
114: *
115:          IF( LSAME( DIAG, 'U' ) ) THEN
116:             VALUE = ONE
117:             IF( LSAME( UPLO, 'U' ) ) THEN
118:                DO 20 J = 1, N
119:                   DO 10 I = 1, MIN( M, J-1 )
120:                      VALUE = MAX( VALUE, ABS( A( I, J ) ) )
121:    10             CONTINUE
122:    20          CONTINUE
123:             ELSE
124:                DO 40 J = 1, N
125:                   DO 30 I = J + 1, M
126:                      VALUE = MAX( VALUE, ABS( A( I, J ) ) )
127:    30             CONTINUE
128:    40          CONTINUE
129:             END IF
130:          ELSE
131:             VALUE = ZERO
132:             IF( LSAME( UPLO, 'U' ) ) THEN
133:                DO 60 J = 1, N
134:                   DO 50 I = 1, MIN( M, J )
135:                      VALUE = MAX( VALUE, ABS( A( I, J ) ) )
136:    50             CONTINUE
137:    60          CONTINUE
138:             ELSE
139:                DO 80 J = 1, N
140:                   DO 70 I = J, M
141:                      VALUE = MAX( VALUE, ABS( A( I, J ) ) )
142:    70             CONTINUE
143:    80          CONTINUE
144:             END IF
145:          END IF
146:       ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
147: *
148: *        Find norm1(A).
149: *
150:          VALUE = ZERO
151:          UDIAG = LSAME( DIAG, 'U' )
152:          IF( LSAME( UPLO, 'U' ) ) THEN
153:             DO 110 J = 1, N
154:                IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
155:                   SUM = ONE
156:                   DO 90 I = 1, J - 1
157:                      SUM = SUM + ABS( A( I, J ) )
158:    90             CONTINUE
159:                ELSE
160:                   SUM = ZERO
161:                   DO 100 I = 1, MIN( M, J )
162:                      SUM = SUM + ABS( A( I, J ) )
163:   100             CONTINUE
164:                END IF
165:                VALUE = MAX( VALUE, SUM )
166:   110       CONTINUE
167:          ELSE
168:             DO 140 J = 1, N
169:                IF( UDIAG ) THEN
170:                   SUM = ONE
171:                   DO 120 I = J + 1, M
172:                      SUM = SUM + ABS( A( I, J ) )
173:   120             CONTINUE
174:                ELSE
175:                   SUM = ZERO
176:                   DO 130 I = J, M
177:                      SUM = SUM + ABS( A( I, J ) )
178:   130             CONTINUE
179:                END IF
180:                VALUE = MAX( VALUE, SUM )
181:   140       CONTINUE
182:          END IF
183:       ELSE IF( LSAME( NORM, 'I' ) ) THEN
184: *
185: *        Find normI(A).
186: *
187:          IF( LSAME( UPLO, 'U' ) ) THEN
188:             IF( LSAME( DIAG, 'U' ) ) THEN
189:                DO 150 I = 1, M
190:                   WORK( I ) = ONE
191:   150          CONTINUE
192:                DO 170 J = 1, N
193:                   DO 160 I = 1, MIN( M, J-1 )
194:                      WORK( I ) = WORK( I ) + ABS( A( I, J ) )
195:   160             CONTINUE
196:   170          CONTINUE
197:             ELSE
198:                DO 180 I = 1, M
199:                   WORK( I ) = ZERO
200:   180          CONTINUE
201:                DO 200 J = 1, N
202:                   DO 190 I = 1, MIN( M, J )
203:                      WORK( I ) = WORK( I ) + ABS( A( I, J ) )
204:   190             CONTINUE
205:   200          CONTINUE
206:             END IF
207:          ELSE
208:             IF( LSAME( DIAG, 'U' ) ) THEN
209:                DO 210 I = 1, N
210:                   WORK( I ) = ONE
211:   210          CONTINUE
212:                DO 220 I = N + 1, M
213:                   WORK( I ) = ZERO
214:   220          CONTINUE
215:                DO 240 J = 1, N
216:                   DO 230 I = J + 1, M
217:                      WORK( I ) = WORK( I ) + ABS( A( I, J ) )
218:   230             CONTINUE
219:   240          CONTINUE
220:             ELSE
221:                DO 250 I = 1, M
222:                   WORK( I ) = ZERO
223:   250          CONTINUE
224:                DO 270 J = 1, N
225:                   DO 260 I = J, M
226:                      WORK( I ) = WORK( I ) + ABS( A( I, J ) )
227:   260             CONTINUE
228:   270          CONTINUE
229:             END IF
230:          END IF
231:          VALUE = ZERO
232:          DO 280 I = 1, M
233:             VALUE = MAX( VALUE, WORK( I ) )
234:   280    CONTINUE
235:       ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
236: *
237: *        Find normF(A).
238: *
239:          IF( LSAME( UPLO, 'U' ) ) THEN
240:             IF( LSAME( DIAG, 'U' ) ) THEN
241:                SCALE = ONE
242:                SUM = MIN( M, N )
243:                DO 290 J = 2, N
244:                   CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
245:   290          CONTINUE
246:             ELSE
247:                SCALE = ZERO
248:                SUM = ONE
249:                DO 300 J = 1, N
250:                   CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
251:   300          CONTINUE
252:             END IF
253:          ELSE
254:             IF( LSAME( DIAG, 'U' ) ) THEN
255:                SCALE = ONE
256:                SUM = MIN( M, N )
257:                DO 310 J = 1, N
258:                   CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
259:      $                         SUM )
260:   310          CONTINUE
261:             ELSE
262:                SCALE = ZERO
263:                SUM = ONE
264:                DO 320 J = 1, N
265:                   CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
266:   320          CONTINUE
267:             END IF
268:          END IF
269:          VALUE = SCALE*SQRT( SUM )
270:       END IF
271: *
272:       SLANTR = VALUE
273:       RETURN
274: *
275: *     End of SLANTR
276: *
277:       END
278: