LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
ssyr2k.f
Go to the documentation of this file.
1 *> \brief \b SSYR2K
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
12 *
13 * .. Scalar Arguments ..
14 * REAL ALPHA,BETA
15 * INTEGER K,LDA,LDB,LDC,N
16 * CHARACTER TRANS,UPLO
17 * ..
18 * .. Array Arguments ..
19 * REAL A(LDA,*),B(LDB,*),C(LDC,*)
20 * ..
21 *
22 *
23 *> \par Purpose:
24 * =============
25 *>
26 *> \verbatim
27 *>
28 *> SSYR2K performs one of the symmetric rank 2k operations
29 *>
30 *> C := alpha*A*B**T + alpha*B*A**T + beta*C,
31 *>
32 *> or
33 *>
34 *> C := alpha*A**T*B + alpha*B**T*A + beta*C,
35 *>
36 *> where alpha and beta are scalars, C is an n by n symmetric matrix
37 *> and A and B are n by k matrices in the first case and k by n
38 *> matrices in the second case.
39 *> \endverbatim
40 *
41 * Arguments:
42 * ==========
43 *
44 *> \param[in] UPLO
45 *> \verbatim
46 *> UPLO is CHARACTER*1
47 *> On entry, UPLO specifies whether the upper or lower
48 *> triangular part of the array C is to be referenced as
49 *> follows:
50 *>
51 *> UPLO = 'U' or 'u' Only the upper triangular part of C
52 *> is to be referenced.
53 *>
54 *> UPLO = 'L' or 'l' Only the lower triangular part of C
55 *> is to be referenced.
56 *> \endverbatim
57 *>
58 *> \param[in] TRANS
59 *> \verbatim
60 *> TRANS is CHARACTER*1
61 *> On entry, TRANS specifies the operation to be performed as
62 *> follows:
63 *>
64 *> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T +
65 *> beta*C.
66 *>
67 *> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
68 *> beta*C.
69 *>
70 *> TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A +
71 *> beta*C.
72 *> \endverbatim
73 *>
74 *> \param[in] N
75 *> \verbatim
76 *> N is INTEGER
77 *> On entry, N specifies the order of the matrix C. N must be
78 *> at least zero.
79 *> \endverbatim
80 *>
81 *> \param[in] K
82 *> \verbatim
83 *> K is INTEGER
84 *> On entry with TRANS = 'N' or 'n', K specifies the number
85 *> of columns of the matrices A and B, and on entry with
86 *> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
87 *> of rows of the matrices A and B. K must be at least zero.
88 *> \endverbatim
89 *>
90 *> \param[in] ALPHA
91 *> \verbatim
92 *> ALPHA is REAL
93 *> On entry, ALPHA specifies the scalar alpha.
94 *> \endverbatim
95 *>
96 *> \param[in] A
97 *> \verbatim
98 *> A is REAL array of DIMENSION ( LDA, ka ), where ka is
99 *> k when TRANS = 'N' or 'n', and is n otherwise.
100 *> Before entry with TRANS = 'N' or 'n', the leading n by k
101 *> part of the array A must contain the matrix A, otherwise
102 *> the leading k by n part of the array A must contain the
103 *> matrix A.
104 *> \endverbatim
105 *>
106 *> \param[in] LDA
107 *> \verbatim
108 *> LDA is INTEGER
109 *> On entry, LDA specifies the first dimension of A as declared
110 *> in the calling (sub) program. When TRANS = 'N' or 'n'
111 *> then LDA must be at least max( 1, n ), otherwise LDA must
112 *> be at least max( 1, k ).
113 *> \endverbatim
114 *>
115 *> \param[in] B
116 *> \verbatim
117 *> B is REAL array of DIMENSION ( LDB, kb ), where kb is
118 *> k when TRANS = 'N' or 'n', and is n otherwise.
119 *> Before entry with TRANS = 'N' or 'n', the leading n by k
120 *> part of the array B must contain the matrix B, otherwise
121 *> the leading k by n part of the array B must contain the
122 *> matrix B.
123 *> \endverbatim
124 *>
125 *> \param[in] LDB
126 *> \verbatim
127 *> LDB is INTEGER
128 *> On entry, LDB specifies the first dimension of B as declared
129 *> in the calling (sub) program. When TRANS = 'N' or 'n'
130 *> then LDB must be at least max( 1, n ), otherwise LDB must
131 *> be at least max( 1, k ).
132 *> \endverbatim
133 *>
134 *> \param[in] BETA
135 *> \verbatim
136 *> BETA is REAL
137 *> On entry, BETA specifies the scalar beta.
138 *> \endverbatim
139 *>
140 *> \param[in,out] C
141 *> \verbatim
142 *> C is REAL array of DIMENSION ( LDC, n ).
143 *> Before entry with UPLO = 'U' or 'u', the leading n by n
144 *> upper triangular part of the array C must contain the upper
145 *> triangular part of the symmetric matrix and the strictly
146 *> lower triangular part of C is not referenced. On exit, the
147 *> upper triangular part of the array C is overwritten by the
148 *> upper triangular part of the updated matrix.
149 *> Before entry with UPLO = 'L' or 'l', the leading n by n
150 *> lower triangular part of the array C must contain the lower
151 *> triangular part of the symmetric matrix and the strictly
152 *> upper triangular part of C is not referenced. On exit, the
153 *> lower triangular part of the array C is overwritten by the
154 *> lower triangular part of the updated matrix.
155 *> \endverbatim
156 *>
157 *> \param[in] LDC
158 *> \verbatim
159 *> LDC is INTEGER
160 *> On entry, LDC specifies the first dimension of C as declared
161 *> in the calling (sub) program. LDC must be at least
162 *> max( 1, n ).
163 *> \endverbatim
164 *
165 * Authors:
166 * ========
167 *
168 *> \author Univ. of Tennessee
169 *> \author Univ. of California Berkeley
170 *> \author Univ. of Colorado Denver
171 *> \author NAG Ltd.
172 *
173 *> \date November 2011
174 *
175 *> \ingroup single_blas_level3
176 *
177 *> \par Further Details:
178 * =====================
179 *>
180 *> \verbatim
181 *>
182 *> Level 3 Blas routine.
183 *>
184 *>
185 *> -- Written on 8-February-1989.
186 *> Jack Dongarra, Argonne National Laboratory.
187 *> Iain Duff, AERE Harwell.
188 *> Jeremy Du Croz, Numerical Algorithms Group Ltd.
189 *> Sven Hammarling, Numerical Algorithms Group Ltd.
190 *> \endverbatim
191 *>
192 * =====================================================================
193  SUBROUTINE ssyr2k(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
194 *
195 * -- Reference BLAS level3 routine (version 3.4.0) --
196 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
197 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
198 * November 2011
199 *
200 * .. Scalar Arguments ..
201  REAL alpha,beta
202  INTEGER k,lda,ldb,ldc,n
203  CHARACTER trans,uplo
204 * ..
205 * .. Array Arguments ..
206  REAL a(lda,*),b(ldb,*),c(ldc,*)
207 * ..
208 *
209 * =====================================================================
210 *
211 * .. External Functions ..
212  LOGICAL lsame
213  EXTERNAL lsame
214 * ..
215 * .. External Subroutines ..
216  EXTERNAL xerbla
217 * ..
218 * .. Intrinsic Functions ..
219  INTRINSIC max
220 * ..
221 * .. Local Scalars ..
222  REAL temp1,temp2
223  INTEGER i,info,j,l,nrowa
224  LOGICAL upper
225 * ..
226 * .. Parameters ..
227  REAL one,zero
228  parameter(one=1.0e+0,zero=0.0e+0)
229 * ..
230 *
231 * Test the input parameters.
232 *
233  IF (lsame(trans,'N')) THEN
234  nrowa = n
235  ELSE
236  nrowa = k
237  END IF
238  upper = lsame(uplo,'U')
239 *
240  info = 0
241  IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN
242  info = 1
243  ELSE IF ((.NOT.lsame(trans,'N')) .AND.
244  + (.NOT.lsame(trans,'T')) .AND.
245  + (.NOT.lsame(trans,'C'))) THEN
246  info = 2
247  ELSE IF (n.LT.0) THEN
248  info = 3
249  ELSE IF (k.LT.0) THEN
250  info = 4
251  ELSE IF (lda.LT.max(1,nrowa)) THEN
252  info = 7
253  ELSE IF (ldb.LT.max(1,nrowa)) THEN
254  info = 9
255  ELSE IF (ldc.LT.max(1,n)) THEN
256  info = 12
257  END IF
258  IF (info.NE.0) THEN
259  CALL xerbla('SSYR2K',info)
260  return
261  END IF
262 *
263 * Quick return if possible.
264 *
265  IF ((n.EQ.0) .OR. (((alpha.EQ.zero).OR.
266  + (k.EQ.0)).AND. (beta.EQ.one))) return
267 *
268 * And when alpha.eq.zero.
269 *
270  IF (alpha.EQ.zero) THEN
271  IF (upper) THEN
272  IF (beta.EQ.zero) THEN
273  DO 20 j = 1,n
274  DO 10 i = 1,j
275  c(i,j) = zero
276  10 continue
277  20 continue
278  ELSE
279  DO 40 j = 1,n
280  DO 30 i = 1,j
281  c(i,j) = beta*c(i,j)
282  30 continue
283  40 continue
284  END IF
285  ELSE
286  IF (beta.EQ.zero) THEN
287  DO 60 j = 1,n
288  DO 50 i = j,n
289  c(i,j) = zero
290  50 continue
291  60 continue
292  ELSE
293  DO 80 j = 1,n
294  DO 70 i = j,n
295  c(i,j) = beta*c(i,j)
296  70 continue
297  80 continue
298  END IF
299  END IF
300  return
301  END IF
302 *
303 * Start the operations.
304 *
305  IF (lsame(trans,'N')) THEN
306 *
307 * Form C := alpha*A*B**T + alpha*B*A**T + C.
308 *
309  IF (upper) THEN
310  DO 130 j = 1,n
311  IF (beta.EQ.zero) THEN
312  DO 90 i = 1,j
313  c(i,j) = zero
314  90 continue
315  ELSE IF (beta.NE.one) THEN
316  DO 100 i = 1,j
317  c(i,j) = beta*c(i,j)
318  100 continue
319  END IF
320  DO 120 l = 1,k
321  IF ((a(j,l).NE.zero) .OR. (b(j,l).NE.zero)) THEN
322  temp1 = alpha*b(j,l)
323  temp2 = alpha*a(j,l)
324  DO 110 i = 1,j
325  c(i,j) = c(i,j) + a(i,l)*temp1 +
326  + b(i,l)*temp2
327  110 continue
328  END IF
329  120 continue
330  130 continue
331  ELSE
332  DO 180 j = 1,n
333  IF (beta.EQ.zero) THEN
334  DO 140 i = j,n
335  c(i,j) = zero
336  140 continue
337  ELSE IF (beta.NE.one) THEN
338  DO 150 i = j,n
339  c(i,j) = beta*c(i,j)
340  150 continue
341  END IF
342  DO 170 l = 1,k
343  IF ((a(j,l).NE.zero) .OR. (b(j,l).NE.zero)) THEN
344  temp1 = alpha*b(j,l)
345  temp2 = alpha*a(j,l)
346  DO 160 i = j,n
347  c(i,j) = c(i,j) + a(i,l)*temp1 +
348  + b(i,l)*temp2
349  160 continue
350  END IF
351  170 continue
352  180 continue
353  END IF
354  ELSE
355 *
356 * Form C := alpha*A**T*B + alpha*B**T*A + C.
357 *
358  IF (upper) THEN
359  DO 210 j = 1,n
360  DO 200 i = 1,j
361  temp1 = zero
362  temp2 = zero
363  DO 190 l = 1,k
364  temp1 = temp1 + a(l,i)*b(l,j)
365  temp2 = temp2 + b(l,i)*a(l,j)
366  190 continue
367  IF (beta.EQ.zero) THEN
368  c(i,j) = alpha*temp1 + alpha*temp2
369  ELSE
370  c(i,j) = beta*c(i,j) + alpha*temp1 +
371  + alpha*temp2
372  END IF
373  200 continue
374  210 continue
375  ELSE
376  DO 240 j = 1,n
377  DO 230 i = j,n
378  temp1 = zero
379  temp2 = zero
380  DO 220 l = 1,k
381  temp1 = temp1 + a(l,i)*b(l,j)
382  temp2 = temp2 + b(l,i)*a(l,j)
383  220 continue
384  IF (beta.EQ.zero) THEN
385  c(i,j) = alpha*temp1 + alpha*temp2
386  ELSE
387  c(i,j) = beta*c(i,j) + alpha*temp1 +
388  + alpha*temp2
389  END IF
390  230 continue
391  240 continue
392  END IF
393  END IF
394 *
395  return
396 *
397 * End of SSYR2K.
398 *
399  END