Add some basic letsimp tests based on bug #3950
[maxima.git] / share / lapack / blas / zsyrk.lisp
blob51b8c803129fc6696c43647c16ff3997d577d00b
1 ;;; Compiled by f2cl version:
2 ;;; ("f2cl1.l,v 2edcbd958861 2012/05/30 03:34:52 toy $"
3 ;;; "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
4 ;;; "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
5 ;;; "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
6 ;;; "f2cl5.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $"
7 ;;; "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
8 ;;; "macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $")
10 ;;; Using Lisp CMU Common Lisp 20d (20D Unicode)
11 ;;;
12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
13 ;;; (:coerce-assigns :as-needed) (:array-type ':array)
14 ;;; (:array-slicing t) (:declare-common nil)
15 ;;; (:float-format double-float))
17 (in-package :blas)
20 (let* ((one (f2cl-lib:cmplx 1.0 0.0)) (zero (f2cl-lib:cmplx 0.0 0.0)))
21 (declare (type (f2cl-lib:complex16) one)
22 (type (f2cl-lib:complex16) zero)
23 (ignorable one zero))
24 (defun zsyrk (uplo trans n k alpha a lda beta c ldc)
25 (declare (type (array f2cl-lib:complex16 (*)) c a)
26 (type (f2cl-lib:complex16) beta alpha)
27 (type (f2cl-lib:integer4) ldc lda k n)
28 (type (simple-string *) trans uplo))
29 (f2cl-lib:with-multi-array-data
30 ((uplo character uplo-%data% uplo-%offset%)
31 (trans character trans-%data% trans-%offset%)
32 (a f2cl-lib:complex16 a-%data% a-%offset%)
33 (c f2cl-lib:complex16 c-%data% c-%offset%))
34 (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) (nrowa 0)
35 (upper nil))
36 (declare (type (f2cl-lib:complex16) temp)
37 (type (f2cl-lib:integer4) i info j l nrowa)
38 (type f2cl-lib:logical upper))
39 (cond
40 ((lsame trans "N")
41 (setf nrowa n))
43 (setf nrowa k)))
44 (setf upper (lsame uplo "U"))
45 (setf info 0)
46 (cond
47 ((and (not upper) (not (lsame uplo "L")))
48 (setf info 1))
49 ((and (not (lsame trans "N")) (not (lsame trans "T")))
50 (setf info 2))
51 ((< n 0)
52 (setf info 3))
53 ((< k 0)
54 (setf info 4))
55 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa)))
56 (setf info 7))
57 ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
58 (setf info 10)))
59 (cond
60 ((/= info 0)
61 (xerbla "ZSYRK " info)
62 (go end_label)))
63 (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one)))
64 (go end_label))
65 (cond
66 ((= alpha zero)
67 (cond
68 (upper
69 (cond
70 ((= beta zero)
71 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
72 ((> j n) nil)
73 (tagbody
74 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
75 ((> i j) nil)
76 (tagbody
77 (setf (f2cl-lib:fref c-%data%
78 (i j)
79 ((1 ldc) (1 *))
80 c-%offset%)
81 zero)
82 label10))
83 label20)))
85 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
86 ((> j n) nil)
87 (tagbody
88 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
89 ((> i j) nil)
90 (tagbody
91 (setf (f2cl-lib:fref c-%data%
92 (i j)
93 ((1 ldc) (1 *))
94 c-%offset%)
95 (* beta
96 (f2cl-lib:fref c-%data%
97 (i j)
98 ((1 ldc) (1 *))
99 c-%offset%)))
100 label30))
101 label40)))))
103 (cond
104 ((= beta zero)
105 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
106 ((> j n) nil)
107 (tagbody
108 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
109 ((> i n) nil)
110 (tagbody
111 (setf (f2cl-lib:fref c-%data%
112 (i j)
113 ((1 ldc) (1 *))
114 c-%offset%)
115 zero)
116 label50))
117 label60)))
119 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
120 ((> j n) nil)
121 (tagbody
122 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
123 ((> i n) nil)
124 (tagbody
125 (setf (f2cl-lib:fref c-%data%
126 (i j)
127 ((1 ldc) (1 *))
128 c-%offset%)
129 (* beta
130 (f2cl-lib:fref c-%data%
131 (i j)
132 ((1 ldc) (1 *))
133 c-%offset%)))
134 label70))
135 label80))))))
136 (go end_label)))
137 (cond
138 ((lsame trans "N")
139 (cond
140 (upper
141 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
142 ((> j n) nil)
143 (tagbody
144 (cond
145 ((= beta zero)
146 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
147 ((> i j) nil)
148 (tagbody
149 (setf (f2cl-lib:fref c-%data%
150 (i j)
151 ((1 ldc) (1 *))
152 c-%offset%)
153 zero)
154 label90)))
155 ((/= beta one)
156 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
157 ((> i j) nil)
158 (tagbody
159 (setf (f2cl-lib:fref c-%data%
160 (i j)
161 ((1 ldc) (1 *))
162 c-%offset%)
163 (* beta
164 (f2cl-lib:fref c-%data%
165 (i j)
166 ((1 ldc) (1 *))
167 c-%offset%)))
168 label100))))
169 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
170 ((> l k) nil)
171 (tagbody
172 (cond
173 ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero)
174 (setf temp
175 (* alpha
176 (f2cl-lib:fref a-%data%
177 (j l)
178 ((1 lda) (1 *))
179 a-%offset%)))
180 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
181 ((> i j) nil)
182 (tagbody
183 (setf (f2cl-lib:fref c-%data%
184 (i j)
185 ((1 ldc) (1 *))
186 c-%offset%)
188 (f2cl-lib:fref c-%data%
189 (i j)
190 ((1 ldc) (1 *))
191 c-%offset%)
192 (* temp
193 (f2cl-lib:fref a-%data%
194 (i l)
195 ((1 lda) (1 *))
196 a-%offset%))))
197 label110))))
198 label120))
199 label130)))
201 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
202 ((> j n) nil)
203 (tagbody
204 (cond
205 ((= beta zero)
206 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
207 ((> i n) nil)
208 (tagbody
209 (setf (f2cl-lib:fref c-%data%
210 (i j)
211 ((1 ldc) (1 *))
212 c-%offset%)
213 zero)
214 label140)))
215 ((/= beta one)
216 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
217 ((> i n) nil)
218 (tagbody
219 (setf (f2cl-lib:fref c-%data%
220 (i j)
221 ((1 ldc) (1 *))
222 c-%offset%)
223 (* beta
224 (f2cl-lib:fref c-%data%
225 (i j)
226 ((1 ldc) (1 *))
227 c-%offset%)))
228 label150))))
229 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
230 ((> l k) nil)
231 (tagbody
232 (cond
233 ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero)
234 (setf temp
235 (* alpha
236 (f2cl-lib:fref a-%data%
237 (j l)
238 ((1 lda) (1 *))
239 a-%offset%)))
240 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
241 ((> i n) nil)
242 (tagbody
243 (setf (f2cl-lib:fref c-%data%
244 (i j)
245 ((1 ldc) (1 *))
246 c-%offset%)
248 (f2cl-lib:fref c-%data%
249 (i j)
250 ((1 ldc) (1 *))
251 c-%offset%)
252 (* temp
253 (f2cl-lib:fref a-%data%
254 (i l)
255 ((1 lda) (1 *))
256 a-%offset%))))
257 label160))))
258 label170))
259 label180)))))
261 (cond
262 (upper
263 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
264 ((> j n) nil)
265 (tagbody
266 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
267 ((> i j) nil)
268 (tagbody
269 (setf temp zero)
270 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
271 ((> l k) nil)
272 (tagbody
273 (setf temp
274 (+ temp
276 (f2cl-lib:fref a-%data%
277 (l i)
278 ((1 lda) (1 *))
279 a-%offset%)
280 (f2cl-lib:fref a-%data%
281 (l j)
282 ((1 lda) (1 *))
283 a-%offset%))))
284 label190))
285 (cond
286 ((= beta zero)
287 (setf (f2cl-lib:fref c-%data%
288 (i j)
289 ((1 ldc) (1 *))
290 c-%offset%)
291 (* alpha temp)))
293 (setf (f2cl-lib:fref c-%data%
294 (i j)
295 ((1 ldc) (1 *))
296 c-%offset%)
297 (+ (* alpha temp)
298 (* beta
299 (f2cl-lib:fref c-%data%
300 (i j)
301 ((1 ldc) (1 *))
302 c-%offset%))))))
303 label200))
304 label210)))
306 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
307 ((> j n) nil)
308 (tagbody
309 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
310 ((> i n) nil)
311 (tagbody
312 (setf temp zero)
313 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
314 ((> l k) nil)
315 (tagbody
316 (setf temp
317 (+ temp
319 (f2cl-lib:fref a-%data%
320 (l i)
321 ((1 lda) (1 *))
322 a-%offset%)
323 (f2cl-lib:fref a-%data%
324 (l j)
325 ((1 lda) (1 *))
326 a-%offset%))))
327 label220))
328 (cond
329 ((= beta zero)
330 (setf (f2cl-lib:fref c-%data%
331 (i j)
332 ((1 ldc) (1 *))
333 c-%offset%)
334 (* alpha temp)))
336 (setf (f2cl-lib:fref c-%data%
337 (i j)
338 ((1 ldc) (1 *))
339 c-%offset%)
340 (+ (* alpha temp)
341 (* beta
342 (f2cl-lib:fref c-%data%
343 (i j)
344 ((1 ldc) (1 *))
345 c-%offset%))))))
346 label230))
347 label240))))))
348 (go end_label)
349 end_label
350 (return (values nil nil nil nil nil nil nil nil nil nil))))))
352 (in-package #-gcl #:cl-user #+gcl "CL-USER")
353 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
354 (eval-when (:load-toplevel :compile-toplevel :execute)
355 (setf (gethash 'fortran-to-lisp::zsyrk fortran-to-lisp::*f2cl-function-info*)
356 (fortran-to-lisp::make-f2cl-finfo
357 :arg-types '((simple-string) (simple-string)
358 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
359 (fortran-to-lisp::complex16)
360 (array fortran-to-lisp::complex16 (*))
361 (fortran-to-lisp::integer4)
362 (fortran-to-lisp::complex16)
363 (array fortran-to-lisp::complex16 (*))
364 (fortran-to-lisp::integer4))
365 :return-values '(nil nil nil nil nil nil nil nil nil nil)
366 :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))))