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