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