Add some basic letsimp tests based on bug #3950
[maxima.git] / share / lapack / blas / zher2k.lisp
blobda8aab48b7e2f788b17dcd40fa3581bda9dd7d10
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 (f2cl-lib:cmplx 0.0 0.0)))
21 (declare (type (double-float 1.0 1.0) one)
22 (type (f2cl-lib:complex16) zero)
23 (ignorable one zero))
24 (defun zher2k (uplo trans n k alpha a lda b ldb$ beta c ldc)
25 (declare (type (double-float) beta)
26 (type (array f2cl-lib:complex16 (*)) c b a)
27 (type (f2cl-lib:complex16) alpha)
28 (type (f2cl-lib:integer4) ldc ldb$ lda k n)
29 (type (simple-string *) trans uplo))
30 (f2cl-lib:with-multi-array-data
31 ((uplo character uplo-%data% uplo-%offset%)
32 (trans character trans-%data% trans-%offset%)
33 (a f2cl-lib:complex16 a-%data% a-%offset%)
34 (b f2cl-lib:complex16 b-%data% b-%offset%)
35 (c f2cl-lib:complex16 c-%data% c-%offset%))
36 (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0)
37 (nrowa 0) (upper nil))
38 (declare (type (f2cl-lib:complex16) temp1 temp2)
39 (type (f2cl-lib:integer4) i info j l nrowa)
40 (type f2cl-lib:logical upper))
41 (cond
42 ((lsame trans "N")
43 (setf nrowa n))
45 (setf nrowa k)))
46 (setf upper (lsame uplo "U"))
47 (setf info 0)
48 (cond
49 ((and (not upper) (not (lsame uplo "L")))
50 (setf info 1))
51 ((and (not (lsame trans "N")) (not (lsame trans "C")))
52 (setf info 2))
53 ((< n 0)
54 (setf info 3))
55 ((< k 0)
56 (setf info 4))
57 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa)))
58 (setf info 7))
59 ((< ldb$
60 (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa)))
61 (setf info 9))
62 ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
63 (setf info 12)))
64 (cond
65 ((/= info 0)
66 (xerbla "ZHER2K" info)
67 (go end_label)))
68 (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one)))
69 (go end_label))
70 (cond
71 ((= alpha zero)
72 (cond
73 (upper
74 (cond
75 ((= beta (f2cl-lib:dble zero))
76 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
77 ((> j n) nil)
78 (tagbody
79 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
80 ((> i j) nil)
81 (tagbody
82 (setf (f2cl-lib:fref c-%data%
83 (i j)
84 ((1 ldc) (1 *))
85 c-%offset%)
86 zero)
87 label10))
88 label20)))
90 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
91 ((> j n) nil)
92 (tagbody
93 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
94 ((> i
95 (f2cl-lib:int-add j
96 (f2cl-lib:int-sub 1)))
97 nil)
98 (tagbody
99 (setf (f2cl-lib:fref c-%data%
100 (i j)
101 ((1 ldc) (1 *))
102 c-%offset%)
103 (* beta
104 (f2cl-lib:fref c-%data%
105 (i j)
106 ((1 ldc) (1 *))
107 c-%offset%)))
108 label30))
109 (setf (f2cl-lib:fref c-%data%
110 (j j)
111 ((1 ldc) (1 *))
112 c-%offset%)
113 (coerce
114 (* beta
115 (f2cl-lib:dble
116 (f2cl-lib:fref c-%data%
117 (j j)
118 ((1 ldc) (1 *))
119 c-%offset%)))
120 'f2cl-lib:complex16))
121 label40)))))
123 (cond
124 ((= beta (f2cl-lib:dble zero))
125 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
126 ((> j n) nil)
127 (tagbody
128 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
129 ((> i n) nil)
130 (tagbody
131 (setf (f2cl-lib:fref c-%data%
132 (i j)
133 ((1 ldc) (1 *))
134 c-%offset%)
135 zero)
136 label50))
137 label60)))
139 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
140 ((> j n) nil)
141 (tagbody
142 (setf (f2cl-lib:fref c-%data%
143 (j j)
144 ((1 ldc) (1 *))
145 c-%offset%)
146 (coerce
147 (* beta
148 (f2cl-lib:dble
149 (f2cl-lib:fref c-%data%
150 (j j)
151 ((1 ldc) (1 *))
152 c-%offset%)))
153 'f2cl-lib:complex16))
154 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1)
155 (f2cl-lib:int-add i 1))
156 ((> i n) nil)
157 (tagbody
158 (setf (f2cl-lib:fref c-%data%
159 (i j)
160 ((1 ldc) (1 *))
161 c-%offset%)
162 (* beta
163 (f2cl-lib:fref c-%data%
164 (i j)
165 ((1 ldc) (1 *))
166 c-%offset%)))
167 label70))
168 label80))))))
169 (go end_label)))
170 (cond
171 ((lsame trans "N")
172 (cond
173 (upper
174 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
175 ((> j n) nil)
176 (tagbody
177 (cond
178 ((= beta (f2cl-lib:dble zero))
179 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
180 ((> i j) nil)
181 (tagbody
182 (setf (f2cl-lib:fref c-%data%
183 (i j)
184 ((1 ldc) (1 *))
185 c-%offset%)
186 zero)
187 label90)))
188 ((/= beta one)
189 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
190 ((> i
191 (f2cl-lib:int-add j
192 (f2cl-lib:int-sub 1)))
193 nil)
194 (tagbody
195 (setf (f2cl-lib:fref c-%data%
196 (i j)
197 ((1 ldc) (1 *))
198 c-%offset%)
199 (* beta
200 (f2cl-lib:fref c-%data%
201 (i j)
202 ((1 ldc) (1 *))
203 c-%offset%)))
204 label100))
205 (setf (f2cl-lib:fref c-%data%
206 (j j)
207 ((1 ldc) (1 *))
208 c-%offset%)
209 (coerce
210 (* beta
211 (f2cl-lib:dble
212 (f2cl-lib:fref c-%data%
213 (j j)
214 ((1 ldc) (1 *))
215 c-%offset%)))
216 'f2cl-lib:complex16)))
218 (setf (f2cl-lib:fref c-%data%
219 (j j)
220 ((1 ldc) (1 *))
221 c-%offset%)
222 (coerce
223 (f2cl-lib:dble
224 (f2cl-lib:fref c-%data%
225 (j j)
226 ((1 ldc) (1 *))
227 c-%offset%))
228 'f2cl-lib:complex16))))
229 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
230 ((> l k) nil)
231 (tagbody
232 (cond
233 ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero)
234 (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero))
235 (setf temp1
236 (* alpha
237 (f2cl-lib:dconjg
238 (f2cl-lib:fref b-%data%
239 (j l)
240 ((1 ldb$) (1 *))
241 b-%offset%))))
242 (setf temp2
243 (coerce
244 (f2cl-lib:dconjg
245 (* alpha
246 (f2cl-lib:fref a-%data%
247 (j l)
248 ((1 lda) (1 *))
249 a-%offset%)))
250 'f2cl-lib:complex16))
251 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
252 ((> i
253 (f2cl-lib:int-add j
254 (f2cl-lib:int-sub
255 1)))
256 nil)
257 (tagbody
258 (setf (f2cl-lib:fref c-%data%
259 (i j)
260 ((1 ldc) (1 *))
261 c-%offset%)
263 (f2cl-lib:fref c-%data%
264 (i j)
265 ((1 ldc) (1 *))
266 c-%offset%)
268 (f2cl-lib:fref a-%data%
269 (i l)
270 ((1 lda) (1 *))
271 a-%offset%)
272 temp1)
274 (f2cl-lib:fref b-%data%
275 (i l)
276 ((1 ldb$) (1 *))
277 b-%offset%)
278 temp2)))
279 label110))
280 (setf (f2cl-lib:fref c-%data%
281 (j j)
282 ((1 ldc) (1 *))
283 c-%offset%)
284 (coerce
286 (f2cl-lib:dble
287 (f2cl-lib:fref c-%data%
288 (j j)
289 ((1 ldc) (1 *))
290 c-%offset%))
291 (f2cl-lib:dble
294 (f2cl-lib:fref a-%data%
295 (j l)
296 ((1 lda) (1 *))
297 a-%offset%)
298 temp1)
300 (f2cl-lib:fref b-%data%
301 (j l)
302 ((1 ldb$) (1 *))
303 b-%offset%)
304 temp2))))
305 'f2cl-lib:complex16))))
306 label120))
307 label130)))
309 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
310 ((> j n) nil)
311 (tagbody
312 (cond
313 ((= beta (f2cl-lib:dble zero))
314 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
315 ((> i n) nil)
316 (tagbody
317 (setf (f2cl-lib:fref c-%data%
318 (i j)
319 ((1 ldc) (1 *))
320 c-%offset%)
321 zero)
322 label140)))
323 ((/= beta one)
324 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1)
325 (f2cl-lib:int-add i 1))
326 ((> i n) nil)
327 (tagbody
328 (setf (f2cl-lib:fref c-%data%
329 (i j)
330 ((1 ldc) (1 *))
331 c-%offset%)
332 (* beta
333 (f2cl-lib:fref c-%data%
334 (i j)
335 ((1 ldc) (1 *))
336 c-%offset%)))
337 label150))
338 (setf (f2cl-lib:fref c-%data%
339 (j j)
340 ((1 ldc) (1 *))
341 c-%offset%)
342 (coerce
343 (* beta
344 (f2cl-lib:dble
345 (f2cl-lib:fref c-%data%
346 (j j)
347 ((1 ldc) (1 *))
348 c-%offset%)))
349 'f2cl-lib:complex16)))
351 (setf (f2cl-lib:fref c-%data%
352 (j j)
353 ((1 ldc) (1 *))
354 c-%offset%)
355 (coerce
356 (f2cl-lib:dble
357 (f2cl-lib:fref c-%data%
358 (j j)
359 ((1 ldc) (1 *))
360 c-%offset%))
361 'f2cl-lib:complex16))))
362 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
363 ((> l k) nil)
364 (tagbody
365 (cond
366 ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero)
367 (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero))
368 (setf temp1
369 (* alpha
370 (f2cl-lib:dconjg
371 (f2cl-lib:fref b-%data%
372 (j l)
373 ((1 ldb$) (1 *))
374 b-%offset%))))
375 (setf temp2
376 (coerce
377 (f2cl-lib:dconjg
378 (* alpha
379 (f2cl-lib:fref a-%data%
380 (j l)
381 ((1 lda) (1 *))
382 a-%offset%)))
383 'f2cl-lib:complex16))
384 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1)
385 (f2cl-lib:int-add i 1))
386 ((> i n) nil)
387 (tagbody
388 (setf (f2cl-lib:fref c-%data%
389 (i j)
390 ((1 ldc) (1 *))
391 c-%offset%)
393 (f2cl-lib:fref c-%data%
394 (i j)
395 ((1 ldc) (1 *))
396 c-%offset%)
398 (f2cl-lib:fref a-%data%
399 (i l)
400 ((1 lda) (1 *))
401 a-%offset%)
402 temp1)
404 (f2cl-lib:fref b-%data%
405 (i l)
406 ((1 ldb$) (1 *))
407 b-%offset%)
408 temp2)))
409 label160))
410 (setf (f2cl-lib:fref c-%data%
411 (j j)
412 ((1 ldc) (1 *))
413 c-%offset%)
414 (coerce
416 (f2cl-lib:dble
417 (f2cl-lib:fref c-%data%
418 (j j)
419 ((1 ldc) (1 *))
420 c-%offset%))
421 (f2cl-lib:dble
424 (f2cl-lib:fref a-%data%
425 (j l)
426 ((1 lda) (1 *))
427 a-%offset%)
428 temp1)
430 (f2cl-lib:fref b-%data%
431 (j l)
432 ((1 ldb$) (1 *))
433 b-%offset%)
434 temp2))))
435 'f2cl-lib:complex16))))
436 label170))
437 label180)))))
439 (cond
440 (upper
441 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
442 ((> j n) nil)
443 (tagbody
444 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
445 ((> i j) nil)
446 (tagbody
447 (setf temp1 zero)
448 (setf temp2 zero)
449 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
450 ((> l k) nil)
451 (tagbody
452 (setf temp1
453 (+ temp1
455 (f2cl-lib:dconjg
456 (f2cl-lib:fref a-%data%
457 (l i)
458 ((1 lda) (1 *))
459 a-%offset%))
460 (f2cl-lib:fref b-%data%
461 (l j)
462 ((1 ldb$) (1 *))
463 b-%offset%))))
464 (setf temp2
465 (+ temp2
467 (f2cl-lib:dconjg
468 (f2cl-lib:fref b-%data%
469 (l i)
470 ((1 ldb$) (1 *))
471 b-%offset%))
472 (f2cl-lib:fref a-%data%
473 (l j)
474 ((1 lda) (1 *))
475 a-%offset%))))
476 label190))
477 (cond
478 ((= i j)
479 (cond
480 ((= beta (f2cl-lib:dble zero))
481 (setf (f2cl-lib:fref c-%data%
482 (j j)
483 ((1 ldc) (1 *))
484 c-%offset%)
485 (coerce
486 (f2cl-lib:dble
487 (+ (* alpha temp1)
488 (* (f2cl-lib:dconjg alpha) temp2)))
489 'f2cl-lib:complex16)))
491 (setf (f2cl-lib:fref c-%data%
492 (j j)
493 ((1 ldc) (1 *))
494 c-%offset%)
495 (coerce
497 (* beta
498 (f2cl-lib:dble
499 (f2cl-lib:fref c-%data%
500 (j j)
501 ((1 ldc) (1 *))
502 c-%offset%)))
503 (f2cl-lib:dble
504 (+ (* alpha temp1)
505 (* (f2cl-lib:dconjg alpha) temp2))))
506 'f2cl-lib:complex16)))))
508 (cond
509 ((= beta (f2cl-lib:dble zero))
510 (setf (f2cl-lib:fref c-%data%
511 (i j)
512 ((1 ldc) (1 *))
513 c-%offset%)
514 (+ (* alpha temp1)
515 (* (f2cl-lib:dconjg alpha) temp2))))
517 (setf (f2cl-lib:fref c-%data%
518 (i j)
519 ((1 ldc) (1 *))
520 c-%offset%)
522 (* beta
523 (f2cl-lib:fref c-%data%
524 (i j)
525 ((1 ldc) (1 *))
526 c-%offset%))
527 (* alpha temp1)
528 (* (f2cl-lib:dconjg alpha) temp2)))))))
529 label200))
530 label210)))
532 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
533 ((> j n) nil)
534 (tagbody
535 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
536 ((> i n) nil)
537 (tagbody
538 (setf temp1 zero)
539 (setf temp2 zero)
540 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
541 ((> l k) nil)
542 (tagbody
543 (setf temp1
544 (+ temp1
546 (f2cl-lib:dconjg
547 (f2cl-lib:fref a-%data%
548 (l i)
549 ((1 lda) (1 *))
550 a-%offset%))
551 (f2cl-lib:fref b-%data%
552 (l j)
553 ((1 ldb$) (1 *))
554 b-%offset%))))
555 (setf temp2
556 (+ temp2
558 (f2cl-lib:dconjg
559 (f2cl-lib:fref b-%data%
560 (l i)
561 ((1 ldb$) (1 *))
562 b-%offset%))
563 (f2cl-lib:fref a-%data%
564 (l j)
565 ((1 lda) (1 *))
566 a-%offset%))))
567 label220))
568 (cond
569 ((= i j)
570 (cond
571 ((= beta (f2cl-lib:dble zero))
572 (setf (f2cl-lib:fref c-%data%
573 (j j)
574 ((1 ldc) (1 *))
575 c-%offset%)
576 (coerce
577 (f2cl-lib:dble
578 (+ (* alpha temp1)
579 (* (f2cl-lib:dconjg alpha) temp2)))
580 'f2cl-lib:complex16)))
582 (setf (f2cl-lib:fref c-%data%
583 (j j)
584 ((1 ldc) (1 *))
585 c-%offset%)
586 (coerce
588 (* beta
589 (f2cl-lib:dble
590 (f2cl-lib:fref c-%data%
591 (j j)
592 ((1 ldc) (1 *))
593 c-%offset%)))
594 (f2cl-lib:dble
595 (+ (* alpha temp1)
596 (* (f2cl-lib:dconjg alpha) temp2))))
597 'f2cl-lib:complex16)))))
599 (cond
600 ((= beta (f2cl-lib:dble zero))
601 (setf (f2cl-lib:fref c-%data%
602 (i j)
603 ((1 ldc) (1 *))
604 c-%offset%)
605 (+ (* alpha temp1)
606 (* (f2cl-lib:dconjg alpha) temp2))))
608 (setf (f2cl-lib:fref c-%data%
609 (i j)
610 ((1 ldc) (1 *))
611 c-%offset%)
613 (* beta
614 (f2cl-lib:fref c-%data%
615 (i j)
616 ((1 ldc) (1 *))
617 c-%offset%))
618 (* alpha temp1)
619 (* (f2cl-lib:dconjg alpha) temp2)))))))
620 label230))
621 label240))))))
622 (go end_label)
623 end_label
624 (return (values nil nil nil nil nil nil nil nil nil nil nil nil))))))
626 (in-package #-gcl #:cl-user #+gcl "CL-USER")
627 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
628 (eval-when (:load-toplevel :compile-toplevel :execute)
629 (setf (gethash 'fortran-to-lisp::zher2k
630 fortran-to-lisp::*f2cl-function-info*)
631 (fortran-to-lisp::make-f2cl-finfo
632 :arg-types '((simple-string) (simple-string)
633 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
634 (fortran-to-lisp::complex16)
635 (array fortran-to-lisp::complex16 (*))
636 (fortran-to-lisp::integer4)
637 (array fortran-to-lisp::complex16 (*))
638 (fortran-to-lisp::integer4) (double-float)
639 (array fortran-to-lisp::complex16 (*))
640 (fortran-to-lisp::integer4))
641 :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil)
642 :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))))