Statistiques
| Révision :

root / src / blas / strmm.f @ 4

Historique | Voir | Annoter | Télécharger (10,92 ko)

1 1 pfleura2
      SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
2 1 pfleura2
*     .. Scalar Arguments ..
3 1 pfleura2
      REAL ALPHA
4 1 pfleura2
      INTEGER LDA,LDB,M,N
5 1 pfleura2
      CHARACTER DIAG,SIDE,TRANSA,UPLO
6 1 pfleura2
*     ..
7 1 pfleura2
*     .. Array Arguments ..
8 1 pfleura2
      REAL A(LDA,*),B(LDB,*)
9 1 pfleura2
*     ..
10 1 pfleura2
*
11 1 pfleura2
*  Purpose
12 1 pfleura2
*  =======
13 1 pfleura2
*
14 1 pfleura2
*  STRMM  performs one of the matrix-matrix operations
15 1 pfleura2
*
16 1 pfleura2
*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
17 1 pfleura2
*
18 1 pfleura2
*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
19 1 pfleura2
*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
20 1 pfleura2
*
21 1 pfleura2
*     op( A ) = A   or   op( A ) = A'.
22 1 pfleura2
*
23 1 pfleura2
*  Arguments
24 1 pfleura2
*  ==========
25 1 pfleura2
*
26 1 pfleura2
*  SIDE   - CHARACTER*1.
27 1 pfleura2
*           On entry,  SIDE specifies whether  op( A ) multiplies B from
28 1 pfleura2
*           the left or right as follows:
29 1 pfleura2
*
30 1 pfleura2
*              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
31 1 pfleura2
*
32 1 pfleura2
*              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
33 1 pfleura2
*
34 1 pfleura2
*           Unchanged on exit.
35 1 pfleura2
*
36 1 pfleura2
*  UPLO   - CHARACTER*1.
37 1 pfleura2
*           On entry, UPLO specifies whether the matrix A is an upper or
38 1 pfleura2
*           lower triangular matrix as follows:
39 1 pfleura2
*
40 1 pfleura2
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
41 1 pfleura2
*
42 1 pfleura2
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
43 1 pfleura2
*
44 1 pfleura2
*           Unchanged on exit.
45 1 pfleura2
*
46 1 pfleura2
*  TRANSA - CHARACTER*1.
47 1 pfleura2
*           On entry, TRANSA specifies the form of op( A ) to be used in
48 1 pfleura2
*           the matrix multiplication as follows:
49 1 pfleura2
*
50 1 pfleura2
*              TRANSA = 'N' or 'n'   op( A ) = A.
51 1 pfleura2
*
52 1 pfleura2
*              TRANSA = 'T' or 't'   op( A ) = A'.
53 1 pfleura2
*
54 1 pfleura2
*              TRANSA = 'C' or 'c'   op( A ) = A'.
55 1 pfleura2
*
56 1 pfleura2
*           Unchanged on exit.
57 1 pfleura2
*
58 1 pfleura2
*  DIAG   - CHARACTER*1.
59 1 pfleura2
*           On entry, DIAG specifies whether or not A is unit triangular
60 1 pfleura2
*           as follows:
61 1 pfleura2
*
62 1 pfleura2
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
63 1 pfleura2
*
64 1 pfleura2
*              DIAG = 'N' or 'n'   A is not assumed to be unit
65 1 pfleura2
*                                  triangular.
66 1 pfleura2
*
67 1 pfleura2
*           Unchanged on exit.
68 1 pfleura2
*
69 1 pfleura2
*  M      - INTEGER.
70 1 pfleura2
*           On entry, M specifies the number of rows of B. M must be at
71 1 pfleura2
*           least zero.
72 1 pfleura2
*           Unchanged on exit.
73 1 pfleura2
*
74 1 pfleura2
*  N      - INTEGER.
75 1 pfleura2
*           On entry, N specifies the number of columns of B.  N must be
76 1 pfleura2
*           at least zero.
77 1 pfleura2
*           Unchanged on exit.
78 1 pfleura2
*
79 1 pfleura2
*  ALPHA  - REAL            .
80 1 pfleura2
*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
81 1 pfleura2
*           zero then  A is not referenced and  B need not be set before
82 1 pfleura2
*           entry.
83 1 pfleura2
*           Unchanged on exit.
84 1 pfleura2
*
85 1 pfleura2
*  A      - REAL             array of DIMENSION ( LDA, k ), where k is m
86 1 pfleura2
*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
87 1 pfleura2
*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
88 1 pfleura2
*           upper triangular part of the array  A must contain the upper
89 1 pfleura2
*           triangular matrix  and the strictly lower triangular part of
90 1 pfleura2
*           A is not referenced.
91 1 pfleura2
*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
92 1 pfleura2
*           lower triangular part of the array  A must contain the lower
93 1 pfleura2
*           triangular matrix  and the strictly upper triangular part of
94 1 pfleura2
*           A is not referenced.
95 1 pfleura2
*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
96 1 pfleura2
*           A  are not referenced either,  but are assumed to be  unity.
97 1 pfleura2
*           Unchanged on exit.
98 1 pfleura2
*
99 1 pfleura2
*  LDA    - INTEGER.
100 1 pfleura2
*           On entry, LDA specifies the first dimension of A as declared
101 1 pfleura2
*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
102 1 pfleura2
*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
103 1 pfleura2
*           then LDA must be at least max( 1, n ).
104 1 pfleura2
*           Unchanged on exit.
105 1 pfleura2
*
106 1 pfleura2
*  B      - REAL             array of DIMENSION ( LDB, n ).
107 1 pfleura2
*           Before entry,  the leading  m by n part of the array  B must
108 1 pfleura2
*           contain the matrix  B,  and  on exit  is overwritten  by the
109 1 pfleura2
*           transformed matrix.
110 1 pfleura2
*
111 1 pfleura2
*  LDB    - INTEGER.
112 1 pfleura2
*           On entry, LDB specifies the first dimension of B as declared
113 1 pfleura2
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
114 1 pfleura2
*           max( 1, m ).
115 1 pfleura2
*           Unchanged on exit.
116 1 pfleura2
*
117 1 pfleura2
*
118 1 pfleura2
*  Level 3 Blas routine.
119 1 pfleura2
*
120 1 pfleura2
*  -- Written on 8-February-1989.
121 1 pfleura2
*     Jack Dongarra, Argonne National Laboratory.
122 1 pfleura2
*     Iain Duff, AERE Harwell.
123 1 pfleura2
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
124 1 pfleura2
*     Sven Hammarling, Numerical Algorithms Group Ltd.
125 1 pfleura2
*
126 1 pfleura2
*
127 1 pfleura2
*     .. External Functions ..
128 1 pfleura2
      LOGICAL LSAME
129 1 pfleura2
      EXTERNAL LSAME
130 1 pfleura2
*     ..
131 1 pfleura2
*     .. External Subroutines ..
132 1 pfleura2
      EXTERNAL XERBLA
133 1 pfleura2
*     ..
134 1 pfleura2
*     .. Intrinsic Functions ..
135 1 pfleura2
      INTRINSIC MAX
136 1 pfleura2
*     ..
137 1 pfleura2
*     .. Local Scalars ..
138 1 pfleura2
      REAL TEMP
139 1 pfleura2
      INTEGER I,INFO,J,K,NROWA
140 1 pfleura2
      LOGICAL LSIDE,NOUNIT,UPPER
141 1 pfleura2
*     ..
142 1 pfleura2
*     .. Parameters ..
143 1 pfleura2
      REAL ONE,ZERO
144 1 pfleura2
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
145 1 pfleura2
*     ..
146 1 pfleura2
*
147 1 pfleura2
*     Test the input parameters.
148 1 pfleura2
*
149 1 pfleura2
      LSIDE = LSAME(SIDE,'L')
150 1 pfleura2
      IF (LSIDE) THEN
151 1 pfleura2
          NROWA = M
152 1 pfleura2
      ELSE
153 1 pfleura2
          NROWA = N
154 1 pfleura2
      END IF
155 1 pfleura2
      NOUNIT = LSAME(DIAG,'N')
156 1 pfleura2
      UPPER = LSAME(UPLO,'U')
157 1 pfleura2
*
158 1 pfleura2
      INFO = 0
159 1 pfleura2
      IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
160 1 pfleura2
          INFO = 1
161 1 pfleura2
      ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
162 1 pfleura2
          INFO = 2
163 1 pfleura2
      ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
164 1 pfleura2
     +         (.NOT.LSAME(TRANSA,'T')) .AND.
165 1 pfleura2
     +         (.NOT.LSAME(TRANSA,'C'))) THEN
166 1 pfleura2
          INFO = 3
167 1 pfleura2
      ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
168 1 pfleura2
          INFO = 4
169 1 pfleura2
      ELSE IF (M.LT.0) THEN
170 1 pfleura2
          INFO = 5
171 1 pfleura2
      ELSE IF (N.LT.0) THEN
172 1 pfleura2
          INFO = 6
173 1 pfleura2
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
174 1 pfleura2
          INFO = 9
175 1 pfleura2
      ELSE IF (LDB.LT.MAX(1,M)) THEN
176 1 pfleura2
          INFO = 11
177 1 pfleura2
      END IF
178 1 pfleura2
      IF (INFO.NE.0) THEN
179 1 pfleura2
          CALL XERBLA('STRMM ',INFO)
180 1 pfleura2
          RETURN
181 1 pfleura2
      END IF
182 1 pfleura2
*
183 1 pfleura2
*     Quick return if possible.
184 1 pfleura2
*
185 1 pfleura2
      IF (M.EQ.0 .OR. N.EQ.0) RETURN
186 1 pfleura2
*
187 1 pfleura2
*     And when  alpha.eq.zero.
188 1 pfleura2
*
189 1 pfleura2
      IF (ALPHA.EQ.ZERO) THEN
190 1 pfleura2
          DO 20 J = 1,N
191 1 pfleura2
              DO 10 I = 1,M
192 1 pfleura2
                  B(I,J) = ZERO
193 1 pfleura2
   10         CONTINUE
194 1 pfleura2
   20     CONTINUE
195 1 pfleura2
          RETURN
196 1 pfleura2
      END IF
197 1 pfleura2
*
198 1 pfleura2
*     Start the operations.
199 1 pfleura2
*
200 1 pfleura2
      IF (LSIDE) THEN
201 1 pfleura2
          IF (LSAME(TRANSA,'N')) THEN
202 1 pfleura2
*
203 1 pfleura2
*           Form  B := alpha*A*B.
204 1 pfleura2
*
205 1 pfleura2
              IF (UPPER) THEN
206 1 pfleura2
                  DO 50 J = 1,N
207 1 pfleura2
                      DO 40 K = 1,M
208 1 pfleura2
                          IF (B(K,J).NE.ZERO) THEN
209 1 pfleura2
                              TEMP = ALPHA*B(K,J)
210 1 pfleura2
                              DO 30 I = 1,K - 1
211 1 pfleura2
                                  B(I,J) = B(I,J) + TEMP*A(I,K)
212 1 pfleura2
   30                         CONTINUE
213 1 pfleura2
                              IF (NOUNIT) TEMP = TEMP*A(K,K)
214 1 pfleura2
                              B(K,J) = TEMP
215 1 pfleura2
                          END IF
216 1 pfleura2
   40                 CONTINUE
217 1 pfleura2
   50             CONTINUE
218 1 pfleura2
              ELSE
219 1 pfleura2
                  DO 80 J = 1,N
220 1 pfleura2
                      DO 70 K = M,1,-1
221 1 pfleura2
                          IF (B(K,J).NE.ZERO) THEN
222 1 pfleura2
                              TEMP = ALPHA*B(K,J)
223 1 pfleura2
                              B(K,J) = TEMP
224 1 pfleura2
                              IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
225 1 pfleura2
                              DO 60 I = K + 1,M
226 1 pfleura2
                                  B(I,J) = B(I,J) + TEMP*A(I,K)
227 1 pfleura2
   60                         CONTINUE
228 1 pfleura2
                          END IF
229 1 pfleura2
   70                 CONTINUE
230 1 pfleura2
   80             CONTINUE
231 1 pfleura2
              END IF
232 1 pfleura2
          ELSE
233 1 pfleura2
*
234 1 pfleura2
*           Form  B := alpha*A'*B.
235 1 pfleura2
*
236 1 pfleura2
              IF (UPPER) THEN
237 1 pfleura2
                  DO 110 J = 1,N
238 1 pfleura2
                      DO 100 I = M,1,-1
239 1 pfleura2
                          TEMP = B(I,J)
240 1 pfleura2
                          IF (NOUNIT) TEMP = TEMP*A(I,I)
241 1 pfleura2
                          DO 90 K = 1,I - 1
242 1 pfleura2
                              TEMP = TEMP + A(K,I)*B(K,J)
243 1 pfleura2
   90                     CONTINUE
244 1 pfleura2
                          B(I,J) = ALPHA*TEMP
245 1 pfleura2
  100                 CONTINUE
246 1 pfleura2
  110             CONTINUE
247 1 pfleura2
              ELSE
248 1 pfleura2
                  DO 140 J = 1,N
249 1 pfleura2
                      DO 130 I = 1,M
250 1 pfleura2
                          TEMP = B(I,J)
251 1 pfleura2
                          IF (NOUNIT) TEMP = TEMP*A(I,I)
252 1 pfleura2
                          DO 120 K = I + 1,M
253 1 pfleura2
                              TEMP = TEMP + A(K,I)*B(K,J)
254 1 pfleura2
  120                     CONTINUE
255 1 pfleura2
                          B(I,J) = ALPHA*TEMP
256 1 pfleura2
  130                 CONTINUE
257 1 pfleura2
  140             CONTINUE
258 1 pfleura2
              END IF
259 1 pfleura2
          END IF
260 1 pfleura2
      ELSE
261 1 pfleura2
          IF (LSAME(TRANSA,'N')) THEN
262 1 pfleura2
*
263 1 pfleura2
*           Form  B := alpha*B*A.
264 1 pfleura2
*
265 1 pfleura2
              IF (UPPER) THEN
266 1 pfleura2
                  DO 180 J = N,1,-1
267 1 pfleura2
                      TEMP = ALPHA
268 1 pfleura2
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
269 1 pfleura2
                      DO 150 I = 1,M
270 1 pfleura2
                          B(I,J) = TEMP*B(I,J)
271 1 pfleura2
  150                 CONTINUE
272 1 pfleura2
                      DO 170 K = 1,J - 1
273 1 pfleura2
                          IF (A(K,J).NE.ZERO) THEN
274 1 pfleura2
                              TEMP = ALPHA*A(K,J)
275 1 pfleura2
                              DO 160 I = 1,M
276 1 pfleura2
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
277 1 pfleura2
  160                         CONTINUE
278 1 pfleura2
                          END IF
279 1 pfleura2
  170                 CONTINUE
280 1 pfleura2
  180             CONTINUE
281 1 pfleura2
              ELSE
282 1 pfleura2
                  DO 220 J = 1,N
283 1 pfleura2
                      TEMP = ALPHA
284 1 pfleura2
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
285 1 pfleura2
                      DO 190 I = 1,M
286 1 pfleura2
                          B(I,J) = TEMP*B(I,J)
287 1 pfleura2
  190                 CONTINUE
288 1 pfleura2
                      DO 210 K = J + 1,N
289 1 pfleura2
                          IF (A(K,J).NE.ZERO) THEN
290 1 pfleura2
                              TEMP = ALPHA*A(K,J)
291 1 pfleura2
                              DO 200 I = 1,M
292 1 pfleura2
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
293 1 pfleura2
  200                         CONTINUE
294 1 pfleura2
                          END IF
295 1 pfleura2
  210                 CONTINUE
296 1 pfleura2
  220             CONTINUE
297 1 pfleura2
              END IF
298 1 pfleura2
          ELSE
299 1 pfleura2
*
300 1 pfleura2
*           Form  B := alpha*B*A'.
301 1 pfleura2
*
302 1 pfleura2
              IF (UPPER) THEN
303 1 pfleura2
                  DO 260 K = 1,N
304 1 pfleura2
                      DO 240 J = 1,K - 1
305 1 pfleura2
                          IF (A(J,K).NE.ZERO) THEN
306 1 pfleura2
                              TEMP = ALPHA*A(J,K)
307 1 pfleura2
                              DO 230 I = 1,M
308 1 pfleura2
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
309 1 pfleura2
  230                         CONTINUE
310 1 pfleura2
                          END IF
311 1 pfleura2
  240                 CONTINUE
312 1 pfleura2
                      TEMP = ALPHA
313 1 pfleura2
                      IF (NOUNIT) TEMP = TEMP*A(K,K)
314 1 pfleura2
                      IF (TEMP.NE.ONE) THEN
315 1 pfleura2
                          DO 250 I = 1,M
316 1 pfleura2
                              B(I,K) = TEMP*B(I,K)
317 1 pfleura2
  250                     CONTINUE
318 1 pfleura2
                      END IF
319 1 pfleura2
  260             CONTINUE
320 1 pfleura2
              ELSE
321 1 pfleura2
                  DO 300 K = N,1,-1
322 1 pfleura2
                      DO 280 J = K + 1,N
323 1 pfleura2
                          IF (A(J,K).NE.ZERO) THEN
324 1 pfleura2
                              TEMP = ALPHA*A(J,K)
325 1 pfleura2
                              DO 270 I = 1,M
326 1 pfleura2
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
327 1 pfleura2
  270                         CONTINUE
328 1 pfleura2
                          END IF
329 1 pfleura2
  280                 CONTINUE
330 1 pfleura2
                      TEMP = ALPHA
331 1 pfleura2
                      IF (NOUNIT) TEMP = TEMP*A(K,K)
332 1 pfleura2
                      IF (TEMP.NE.ONE) THEN
333 1 pfleura2
                          DO 290 I = 1,M
334 1 pfleura2
                              B(I,K) = TEMP*B(I,K)
335 1 pfleura2
  290                     CONTINUE
336 1 pfleura2
                      END IF
337 1 pfleura2
  300             CONTINUE
338 1 pfleura2
              END IF
339 1 pfleura2
          END IF
340 1 pfleura2
      END IF
341 1 pfleura2
*
342 1 pfleura2
      RETURN
343 1 pfleura2
*
344 1 pfleura2
*     End of STRMM .
345 1 pfleura2
*
346 1 pfleura2
      END