Statistiques
| Révision :

root / src / blas / ctrmm.f @ 7

Historique | Voir | Annoter | Télécharger (12,61 ko)

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