001:       SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
002: *     .. Scalar Arguments ..
003:       REAL ALPHA
004:       INTEGER LDA,LDB,M,N
005:       CHARACTER DIAG,SIDE,TRANSA,UPLO
006: *     ..
007: *     .. Array Arguments ..
008:       REAL A(LDA,*),B(LDB,*)
009: *     ..
010: *
011: *  Purpose
012: *  =======
013: *
014: *  STRMM  performs one of the matrix-matrix operations
015: *
016: *     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
017: *
018: *  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
019: *  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
020: *
021: *     op( A ) = A   or   op( A ) = A'.
022: *
023: *  Arguments
024: *  ==========
025: *
026: *  SIDE   - CHARACTER*1.
027: *           On entry,  SIDE specifies whether  op( A ) multiplies B from
028: *           the left or right as follows:
029: *
030: *              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
031: *
032: *              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
033: *
034: *           Unchanged on exit.
035: *
036: *  UPLO   - CHARACTER*1.
037: *           On entry, UPLO specifies whether the matrix A is an upper or
038: *           lower triangular matrix as follows:
039: *
040: *              UPLO = 'U' or 'u'   A is an upper triangular matrix.
041: *
042: *              UPLO = 'L' or 'l'   A is a lower triangular matrix.
043: *
044: *           Unchanged on exit.
045: *
046: *  TRANSA - CHARACTER*1.
047: *           On entry, TRANSA specifies the form of op( A ) to be used in
048: *           the matrix multiplication as follows:
049: *
050: *              TRANSA = 'N' or 'n'   op( A ) = A.
051: *
052: *              TRANSA = 'T' or 't'   op( A ) = A'.
053: *
054: *              TRANSA = 'C' or 'c'   op( A ) = A'.
055: *
056: *           Unchanged on exit.
057: *
058: *  DIAG   - CHARACTER*1.
059: *           On entry, DIAG specifies whether or not A is unit triangular
060: *           as follows:
061: *
062: *              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
063: *
064: *              DIAG = 'N' or 'n'   A is not assumed to be unit
065: *                                  triangular.
066: *
067: *           Unchanged on exit.
068: *
069: *  M      - INTEGER.
070: *           On entry, M specifies the number of rows of B. M must be at
071: *           least zero.
072: *           Unchanged on exit.
073: *
074: *  N      - INTEGER.
075: *           On entry, N specifies the number of columns of B.  N must be
076: *           at least zero.
077: *           Unchanged on exit.
078: *
079: *  ALPHA  - REAL            .
080: *           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
081: *           zero then  A is not referenced and  B need not be set before
082: *           entry.
083: *           Unchanged on exit.
084: *
085: *  A      - REAL             array of DIMENSION ( LDA, k ), where k is m
086: *           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
087: *           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
088: *           upper triangular part of the array  A must contain the upper
089: *           triangular matrix  and the strictly lower triangular part of
090: *           A is not referenced.
091: *           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
092: *           lower triangular part of the array  A must contain the lower
093: *           triangular matrix  and the strictly upper triangular part of
094: *           A is not referenced.
095: *           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
096: *           A  are not referenced either,  but are assumed to be  unity.
097: *           Unchanged on exit.
098: *
099: *  LDA    - INTEGER.
100: *           On entry, LDA specifies the first dimension of A as declared
101: *           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
102: *           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
103: *           then LDA must be at least max( 1, n ).
104: *           Unchanged on exit.
105: *
106: *  B      - REAL             array of DIMENSION ( LDB, n ).
107: *           Before entry,  the leading  m by n part of the array  B must
108: *           contain the matrix  B,  and  on exit  is overwritten  by the
109: *           transformed matrix.
110: *
111: *  LDB    - INTEGER.
112: *           On entry, LDB specifies the first dimension of B as declared
113: *           in  the  calling  (sub)  program.   LDB  must  be  at  least
114: *           max( 1, m ).
115: *           Unchanged on exit.
116: *
117: *
118: *  Level 3 Blas routine.
119: *
120: *  -- Written on 8-February-1989.
121: *     Jack Dongarra, Argonne National Laboratory.
122: *     Iain Duff, AERE Harwell.
123: *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
124: *     Sven Hammarling, Numerical Algorithms Group Ltd.
125: *
126: *
127: *     .. External Functions ..
128:       LOGICAL LSAME
129:       EXTERNAL LSAME
130: *     ..
131: *     .. External Subroutines ..
132:       EXTERNAL XERBLA
133: *     ..
134: *     .. Intrinsic Functions ..
135:       INTRINSIC MAX
136: *     ..
137: *     .. Local Scalars ..
138:       REAL TEMP
139:       INTEGER I,INFO,J,K,NROWA
140:       LOGICAL LSIDE,NOUNIT,UPPER
141: *     ..
142: *     .. Parameters ..
143:       REAL ONE,ZERO
144:       PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
145: *     ..
146: *
147: *     Test the input parameters.
148: *
149:       LSIDE = LSAME(SIDE,'L')
150:       IF (LSIDE) THEN
151:           NROWA = M
152:       ELSE
153:           NROWA = N
154:       END IF
155:       NOUNIT = LSAME(DIAG,'N')
156:       UPPER = LSAME(UPLO,'U')
157: *
158:       INFO = 0
159:       IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
160:           INFO = 1
161:       ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
162:           INFO = 2
163:       ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
164:      +         (.NOT.LSAME(TRANSA,'T')) .AND.
165:      +         (.NOT.LSAME(TRANSA,'C'))) THEN
166:           INFO = 3
167:       ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
168:           INFO = 4
169:       ELSE IF (M.LT.0) THEN
170:           INFO = 5
171:       ELSE IF (N.LT.0) THEN
172:           INFO = 6
173:       ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
174:           INFO = 9
175:       ELSE IF (LDB.LT.MAX(1,M)) THEN
176:           INFO = 11
177:       END IF
178:       IF (INFO.NE.0) THEN
179:           CALL XERBLA('STRMM ',INFO)
180:           RETURN
181:       END IF
182: *
183: *     Quick return if possible.
184: *
185:       IF (M.EQ.0 .OR. N.EQ.0) RETURN
186: *
187: *     And when  alpha.eq.zero.
188: *
189:       IF (ALPHA.EQ.ZERO) THEN
190:           DO 20 J = 1,N
191:               DO 10 I = 1,M
192:                   B(I,J) = ZERO
193:    10         CONTINUE
194:    20     CONTINUE
195:           RETURN
196:       END IF
197: *
198: *     Start the operations.
199: *
200:       IF (LSIDE) THEN
201:           IF (LSAME(TRANSA,'N')) THEN
202: *
203: *           Form  B := alpha*A*B.
204: *
205:               IF (UPPER) THEN
206:                   DO 50 J = 1,N
207:                       DO 40 K = 1,M
208:                           IF (B(K,J).NE.ZERO) THEN
209:                               TEMP = ALPHA*B(K,J)
210:                               DO 30 I = 1,K - 1
211:                                   B(I,J) = B(I,J) + TEMP*A(I,K)
212:    30                         CONTINUE
213:                               IF (NOUNIT) TEMP = TEMP*A(K,K)
214:                               B(K,J) = TEMP
215:                           END IF
216:    40                 CONTINUE
217:    50             CONTINUE
218:               ELSE
219:                   DO 80 J = 1,N
220:                       DO 70 K = M,1,-1
221:                           IF (B(K,J).NE.ZERO) THEN
222:                               TEMP = ALPHA*B(K,J)
223:                               B(K,J) = TEMP
224:                               IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
225:                               DO 60 I = K + 1,M
226:                                   B(I,J) = B(I,J) + TEMP*A(I,K)
227:    60                         CONTINUE
228:                           END IF
229:    70                 CONTINUE
230:    80             CONTINUE
231:               END IF
232:           ELSE
233: *
234: *           Form  B := alpha*A'*B.
235: *
236:               IF (UPPER) THEN
237:                   DO 110 J = 1,N
238:                       DO 100 I = M,1,-1
239:                           TEMP = B(I,J)
240:                           IF (NOUNIT) TEMP = TEMP*A(I,I)
241:                           DO 90 K = 1,I - 1
242:                               TEMP = TEMP + A(K,I)*B(K,J)
243:    90                     CONTINUE
244:                           B(I,J) = ALPHA*TEMP
245:   100                 CONTINUE
246:   110             CONTINUE
247:               ELSE
248:                   DO 140 J = 1,N
249:                       DO 130 I = 1,M
250:                           TEMP = B(I,J)
251:                           IF (NOUNIT) TEMP = TEMP*A(I,I)
252:                           DO 120 K = I + 1,M
253:                               TEMP = TEMP + A(K,I)*B(K,J)
254:   120                     CONTINUE
255:                           B(I,J) = ALPHA*TEMP
256:   130                 CONTINUE
257:   140             CONTINUE
258:               END IF
259:           END IF
260:       ELSE
261:           IF (LSAME(TRANSA,'N')) THEN
262: *
263: *           Form  B := alpha*B*A.
264: *
265:               IF (UPPER) THEN
266:                   DO 180 J = N,1,-1
267:                       TEMP = ALPHA
268:                       IF (NOUNIT) TEMP = TEMP*A(J,J)
269:                       DO 150 I = 1,M
270:                           B(I,J) = TEMP*B(I,J)
271:   150                 CONTINUE
272:                       DO 170 K = 1,J - 1
273:                           IF (A(K,J).NE.ZERO) THEN
274:                               TEMP = ALPHA*A(K,J)
275:                               DO 160 I = 1,M
276:                                   B(I,J) = B(I,J) + TEMP*B(I,K)
277:   160                         CONTINUE
278:                           END IF
279:   170                 CONTINUE
280:   180             CONTINUE
281:               ELSE
282:                   DO 220 J = 1,N
283:                       TEMP = ALPHA
284:                       IF (NOUNIT) TEMP = TEMP*A(J,J)
285:                       DO 190 I = 1,M
286:                           B(I,J) = TEMP*B(I,J)
287:   190                 CONTINUE
288:                       DO 210 K = J + 1,N
289:                           IF (A(K,J).NE.ZERO) THEN
290:                               TEMP = ALPHA*A(K,J)
291:                               DO 200 I = 1,M
292:                                   B(I,J) = B(I,J) + TEMP*B(I,K)
293:   200                         CONTINUE
294:                           END IF
295:   210                 CONTINUE
296:   220             CONTINUE
297:               END IF
298:           ELSE
299: *
300: *           Form  B := alpha*B*A'.
301: *
302:               IF (UPPER) THEN
303:                   DO 260 K = 1,N
304:                       DO 240 J = 1,K - 1
305:                           IF (A(J,K).NE.ZERO) THEN
306:                               TEMP = ALPHA*A(J,K)
307:                               DO 230 I = 1,M
308:                                   B(I,J) = B(I,J) + TEMP*B(I,K)
309:   230                         CONTINUE
310:                           END IF
311:   240                 CONTINUE
312:                       TEMP = ALPHA
313:                       IF (NOUNIT) TEMP = TEMP*A(K,K)
314:                       IF (TEMP.NE.ONE) THEN
315:                           DO 250 I = 1,M
316:                               B(I,K) = TEMP*B(I,K)
317:   250                     CONTINUE
318:                       END IF
319:   260             CONTINUE
320:               ELSE
321:                   DO 300 K = N,1,-1
322:                       DO 280 J = K + 1,N
323:                           IF (A(J,K).NE.ZERO) THEN
324:                               TEMP = ALPHA*A(J,K)
325:                               DO 270 I = 1,M
326:                                   B(I,J) = B(I,J) + TEMP*B(I,K)
327:   270                         CONTINUE
328:                           END IF
329:   280                 CONTINUE
330:                       TEMP = ALPHA
331:                       IF (NOUNIT) TEMP = TEMP*A(K,K)
332:                       IF (TEMP.NE.ONE) THEN
333:                           DO 290 I = 1,M
334:                               B(I,K) = TEMP*B(I,K)
335:   290                     CONTINUE
336:                       END IF
337:   300             CONTINUE
338:               END IF
339:           END IF
340:       END IF
341: *
342:       RETURN
343: *
344: *     End of STRMM .
345: *
346:       END
347: