source: project/release/5/blas/trunk/blas.scm @ 35678

Last change on this file since 35678 was 35677, checked in by Ivan Raikov, 2 years ago

ported blas to C5

File size: 119.7 KB
Line 
1;; Scheme interface to BLAS
2
3(module blas
4
5        (RowMajor
6         ColMajor
7         NoTrans
8         Trans
9         ConjTrans
10         Left
11         Right
12         Upper
13         Lower
14         Unit
15         NonUnit
16
17         sicopy
18         dicopy
19         cicopy
20         zicopy
21
22         scopy
23         dcopy
24         ccopy
25         zcopy
26
27         unsafe-sgemm!
28         unsafe-dgemm!
29         unsafe-cgemm!
30         unsafe-zgemm!
31         sgemm!
32         dgemm!
33         cgemm!
34         zgemm!
35         sgemm
36         dgemm
37         cgemm
38         zgemm
39
40         unsafe-ssymm!
41         unsafe-dsymm!
42         unsafe-csymm!
43         unsafe-zsymm!
44         ssymm!
45         dsymm!
46         csymm!
47         zsymm!
48         ssymm
49         dsymm
50         csymm
51         zsymm
52
53         unsafe-chemm!
54         unsafe-zhemm!
55         chemm!
56         zhemm!
57         chemm
58         zhemm
59
60         unsafe-ssyrk!
61         unsafe-dsyrk!
62         unsafe-csyrk!
63         unsafe-zsyrk!
64         ssyrk!
65         dsyrk!
66         csyrk!
67         zsyrk!
68         ssyrk
69         dsyrk
70         csyrk
71         zsyrk
72
73         unsafe-cherk!
74         unsafe-zherk!
75         cherk!
76         zherk!
77         cherk
78         zherk
79
80         unsafe-ssyr2k!
81         unsafe-dsyr2k!
82         unsafe-csyr2k!
83         unsafe-zsyr2k!
84         ssyr2k!
85         dsyr2k!
86         csyr2k!
87         zsyr2k!
88         ssyr2k
89         dsyr2k
90         csyr2k
91         zsyr2k
92
93         unsafe-cher2k!
94         unsafe-zher2k!
95         cher2k!
96         zher2k!
97         cher2k
98         zher2k
99
100         unsafe-strmm!
101         unsafe-dtrmm!
102         unsafe-ctrmm!
103         unsafe-ztrmm!
104         strmm!
105         dtrmm!
106         ctrmm!
107         ztrmm!
108         strmm
109         dtrmm
110         ctrmm
111         ztrmm
112
113         unsafe-strsm!
114         unsafe-dtrsm!
115         unsafe-ctrsm!
116         unsafe-ztrsm!
117         strsm!
118         dtrsm!
119         ctrsm!
120         ztrsm!
121         strsm
122         dtrsm
123         ctrsm
124         ztrsm
125
126         unsafe-sgemv!
127         unsafe-dgemv!
128         unsafe-cgemv!
129         unsafe-zgemv!
130         sgemv!
131         dgemv!
132         cgemv!
133         zgemv!
134         sgemv
135         dgemv
136         cgemv
137         zgemv
138
139         unsafe-chemv!
140         unsafe-zhemv!
141         chemv!
142         zhemv!
143         chemv
144         zhemv
145         unsafe-chbmv!
146         unsafe-zhbmv!
147         chbmv!
148         zhbmv!
149         chbmv
150         zhbmv
151         unsafe-chpmv!
152         unsafe-zhpmv!
153         chpmv!
154         zhpmv!
155         chpmv
156         zhpmv
157         unsafe-ssymv!
158         unsafe-dsymv!
159         ssymv!
160         dsymv!
161         ssymv
162         dsymv
163         unsafe-ssbmv!
164         unsafe-dsbmv!
165         ssbmv!
166         dsbmv!
167         ssbmv
168         dsbmv
169         unsafe-sspmv!
170         unsafe-dspmv!
171         sspmv!
172         dspmv!
173         sspmv
174         dspmv
175         unsafe-strmv!
176         unsafe-dtrmv!
177         unsafe-ctrmv!
178         unsafe-ztrmv!
179         strmv!
180         dtrmv!
181         ctrmv!
182         ztrmv!
183         strmv
184         dtrmv
185         ctrmv
186         ztrmv
187         unsafe-stbmv!
188         unsafe-dtbmv!
189         unsafe-ctbmv!
190         unsafe-ztbmv!
191         stbmv!
192         dtbmv!
193         ctbmv!
194         ztbmv!
195         stbmv
196         dtbmv
197         ctbmv
198         ztbmv
199         unsafe-stpmv!
200         unsafe-dtpmv!
201         unsafe-ctpmv!
202         unsafe-ztpmv!
203         stpmv!
204         dtpmv!
205         ctpmv!
206         ztpmv!
207         stpmv
208         dtpmv
209         ctpmv
210         ztpmv
211         unsafe-strsv!
212         unsafe-dtrsv!
213         unsafe-ctrsv!
214         unsafe-ztrsv!
215         strsv!
216         dtrsv!
217         ctrsv!
218         ztrsv!
219         strsv
220         dtrsv
221         ctrsv
222         ztrsv
223         unsafe-stbsv!
224         unsafe-dtbsv!
225         unsafe-ctbsv!
226         unsafe-ztbsv!
227         stbsv!
228         dtbsv!
229         ctbsv!
230         ztbsv!
231         stbsv
232         dtbsv
233         ctbsv
234         ztbsv
235         unsafe-stpsv!
236         unsafe-dtpsv!
237         unsafe-ctpsv!
238         unsafe-ztpsv!
239         stpsv!
240         dtpsv!
241         ctpsv!
242         ztpsv!
243         stpsv
244         dtpsv
245         ctpsv
246         ztpsv
247         unsafe-sger!
248         unsafe-dger!
249         sger!
250         dger!
251         sger
252         dger
253         unsafe-siger!
254         unsafe-diger!
255         siger!
256         diger!
257         siger
258         diger
259         unsafe-cgeru!
260         unsafe-zgeru!
261         cgeru!
262         zgeru!
263         cgeru
264         zgeru
265         unsafe-cgerc!
266         unsafe-zgerc!
267         cgerc!
268         zgerc!
269         cgerc
270         zgerc
271         unsafe-cher!
272         unsafe-zher!
273         cher!
274         zher!
275         cher
276         zher
277         unsafe-chpr!
278         unsafe-zhpr!
279         chpr!
280         zhpr!
281         chpr
282         zhpr
283         unsafe-cher2!
284         unsafe-zher2!
285         cher2!
286         zher2!
287         cher2
288         zher2
289         unsafe-chpr2!
290         unsafe-zhpr2!
291         chpr2!
292         zhpr2!
293         chpr2
294         zhpr2
295         unsafe-ssyr!
296         unsafe-dsyr!
297         ssyr!
298         dsyr!
299         ssyr
300         dsyr
301         unsafe-sspr!
302         unsafe-dspr!
303         sspr!
304         dspr!
305         sspr
306         dspr
307         unsafe-ssyr2!
308         unsafe-dsyr2!
309         ssyr2!
310         dsyr2!
311         ssyr2
312         dsyr2
313         unsafe-sspr2!
314         unsafe-dspr2!
315         sspr2!
316         dspr2!
317         sspr2
318         dspr2
319
320         unsafe-srot!
321         unsafe-drot!
322         srot!
323         drot!
324         srot
325         drot
326         unsafe-srotm!
327         unsafe-drotm!
328         srotm!
329         drotm!
330         srotm
331         drotm
332         unsafe-sswap!
333         unsafe-dswap!
334         unsafe-cswap!
335         unsafe-zswap!
336         sswap!
337         dswap!
338         cswap!
339         zswap!
340         sswap
341         dswap
342         cswap
343         zswap
344         unsafe-sscal!
345         unsafe-dscal!
346         unsafe-cscal!
347         unsafe-zscal!
348         sscal!
349         dscal!
350         cscal!
351         zscal!
352         sscal
353         dscal
354         cscal
355         zscal
356         unsafe-saxpy!
357         unsafe-daxpy!
358         unsafe-caxpy!
359         unsafe-zaxpy!
360         saxpy!
361         daxpy!
362         caxpy!
363         zaxpy!
364         saxpy
365         daxpy
366         caxpy
367         zaxpy
368         unsafe-siaxpy!
369         unsafe-diaxpy!
370         unsafe-ciaxpy!
371         unsafe-ziaxpy!
372         siaxpy!
373         diaxpy!
374         ciaxpy!
375         ziaxpy!
376         siaxpy
377         diaxpy
378         ciaxpy
379         ziaxpy
380         sdot
381         ddot
382         cdotu
383         zdotu
384         cdotc
385         zdotc
386         snrm2
387         dnrm2
388         cnrm2
389         znrm2
390         sasum
391         dasum
392         casum
393         zasum
394         samax
395         damax
396         camax
397         zamax
398         )
399
400        (import scheme (chicken base) (chicken foreign) (chicken fixnum) (chicken string)
401                srfi-4 bind)
402        (import-for-syntax (chicken string))
403
404        (bind* #<<EOF
405
406               typedef float CCOMPLEX;
407               typedef double ZCOMPLEX;
408               typedef int CBLAS_INDEX;
409
410
411               /*
412               * Enumerated and derived types
413               */
414
415               enum CBLAS_ORDER {CblasRowMajor=101, CblasColMajor=102};
416               enum CBLAS_TRANSPOSE {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113};
417               enum CBLAS_UPLO {CblasUpper=121, CblasLower=122};
418               enum CBLAS_DIAG {CblasNonUnit=131, CblasUnit=132};
419               enum CBLAS_SIDE {CblasLeft=141, CblasRight=142};
420
421               /*
422               * ===========================================================================
423               * Prototypes for level 1 BLAS routines
424               * ===========================================================================
425               */
426
427               /* 
428               * Routines with standard 4 prefixes (s, d, c, z)
429               */
430               void cblas_sswap(const int N, float *X, const int incX, 
431                                      float *Y, const int incY);
432               void cblas_scopy(const int N, const float *X, const int incX, 
433                                      float *Y, const int incY);
434               void cblas_saxpy(const int N, const float alpha, const float *X,
435                                      const int incX, float *Y, const int incY);
436
437               void cblas_dswap(const int N, double *X, const int incX, 
438                                      double *Y, const int incY);
439               void cblas_dcopy(const int N, const double *X, const int incX, 
440                                      double *Y, const int incY);
441               void cblas_daxpy(const int N, const double alpha, const double *X,
442                                      const int incX, double *Y, const int incY);
443
444               void cblas_cswap(const int N, CCOMPLEX *X, const int incX, 
445                                      CCOMPLEX *Y, const int incY);
446               void cblas_ccopy(const int N, const CCOMPLEX *X, const int incX, 
447                                      CCOMPLEX *Y, const int incY);
448               void cblas_caxpy(const int N, const CCOMPLEX *alpha, const CCOMPLEX *X,
449                                      const int incX, CCOMPLEX *Y, const int incY);
450
451               void cblas_zswap(const int N, ZCOMPLEX *X, const int incX, 
452                                      ZCOMPLEX *Y, const int incY);
453               void cblas_zcopy(const int N, const ZCOMPLEX *X, const int incX, 
454                                      ZCOMPLEX *Y, const int incY);
455               void cblas_zaxpy(const int N, const ZCOMPLEX *alpha, const ZCOMPLEX *X,
456                                      const int incX, ZCOMPLEX *Y, const int incY);
457
458
459               /* 
460               * Routines with S and D prefix only
461               */
462               void cblas_srotg(float *a, float *b, float *c, float *s);
463               void cblas_srotmg(float *d1, float *d2, float *b1, const float b2, float *P);
464               void cblas_srot(const int N, float *X, const int incX,
465                                     float *Y, const int incY, const float c, const float s);
466               void cblas_srotm(const int N, float *X, const int incX,
467                                      float *Y, const int incY, const float *P);
468
469               void cblas_drotg(double *a, double *b, double *c, double *s);
470               void cblas_drotmg(double *d1, double *d2, double *b1, const double b2, double *P);
471               void cblas_drot(const int N, double *X, const int incX,
472                                     double *Y, const int incY, const double c, const double  s);
473               void cblas_drotm(const int N, double *X, const int incX,
474                                      double *Y, const int incY, const double *P);
475
476
477               /* 
478               * Routines with S D C Z CS and ZD prefixes
479               */
480               void cblas_sscal(const int N, const float alpha, float *X, const int incX);
481               void cblas_dscal(const int N, const double alpha, double *X, const int incX);
482               void cblas_cscal(const int N, const CCOMPLEX *alpha, CCOMPLEX *X, const int incX);
483               void cblas_zscal(const int N, const ZCOMPLEX *alpha, ZCOMPLEX *X, const int incX);
484               void cblas_csscal(const int N, const float alpha, CCOMPLEX *X, const int incX);
485               void cblas_zdscal(const int N, const double alpha, ZCOMPLEX *X, const int incX);
486
487
488               /* Offset variations of the copy, axpy routines */
489
490               void sicopy(const int N, const float *X, const int incX, const
491                                 int offsetX, float *Y, const int incY, const int offsetY)
492               {
493                cblas_scopy (N, X+offsetX, incX, Y+offsetY, incY);
494                            }
495
496               void dicopy(const int N, const double *X, const int incX, const
497                                 int offsetX, double *Y, const int incY, const int offsetY)
498               {
499                cblas_dcopy (N, X+offsetX, incX, Y+offsetY, incY);
500               }
501
502
503               void cicopy(const int N, const CCOMPLEX *X, const int incX, const
504                                 int offsetX, CCOMPLEX *Y, const int incY, const int offsetY)
505               {
506                cblas_ccopy (N, X+(2*offsetX), incX, Y+(2*offsetY), incY);
507               }
508
509               void zicopy(const int N, const ZCOMPLEX *X, const int incX, const
510                                 int offsetX, ZCOMPLEX *Y, const int incY, const int offsetY)
511               {
512                cblas_zcopy (N, X+(2*offsetX), incX, Y+(2*offsetY), incY);
513                            }
514
515
516               void cblas_siaxpy(const int N, const float alpha, 
517                                       const float *X, const int incX, const int offsetX, 
518                                       float *Y, const int incY, const int offsetY)
519               {
520
521                cblas_saxpy(N, alpha, X+offsetX, incX, Y+offsetY, incY);
522                           }
523
524
525               void cblas_diaxpy(const int N, const double alpha, 
526                                       const double *X, const int incX, const int offsetX, 
527                                       double *Y, const int incY, const int offsetY)
528               {
529
530                cblas_daxpy(N, alpha, X+offsetX, incX, Y+offsetY, incY);
531                           }
532
533
534               void cblas_ciaxpy(const int N, const CCOMPLEX *alpha, 
535                                       const CCOMPLEX *X, const int incX, const int offsetX, 
536                                       CCOMPLEX *Y, const int incY, const int offsetY)
537               {
538                cblas_caxpy(N, alpha, X+(2*offsetX), incX, Y+(2*offsetY), incY);
539                           }
540
541
542               void cblas_ziaxpy(const int N, const ZCOMPLEX *alpha, 
543                                       const ZCOMPLEX *X, const int incX, const int offsetX, 
544                                       ZCOMPLEX *Y, const int incY, const int offsetY)
545               {
546                cblas_zaxpy(N, alpha, X+(2*offsetX), incX, Y+(2*offsetY), incY);
547                           }
548EOF
549               )
550
551
552        (define RowMajor  CblasRowMajor)
553        (define ColMajor  CblasColMajor)
554        (define NoTrans   CblasNoTrans)
555        (define Trans     CblasTrans)
556        (define ConjTrans CblasConjTrans)
557        (define Upper     CblasUpper)
558        (define Lower     CblasLower)
559        (define NonUnit   CblasNonUnit)
560        (define Unit      CblasUnit)
561        (define Left      CblasLeft)
562        (define Right     CblasRight)
563
564
565        (define (scopy x)
566          (let ((n (f32vector-length x)))
567            (let ((y  (make-f32vector n)))
568              (cblas_scopy n x 1 y 1)
569              y)))
570
571        (define (dcopy x)
572          (let ((n (f64vector-length x)))
573            (let ((y  (make-f64vector n)))
574              (cblas_dcopy n x 1 y 1)
575              y)))
576
577        (define (ccopy x)
578          (let ((n (fx/ (f32vector-length x) 2)))
579            (let ((y  (make-f32vector (fx* 2 n))))
580              (cblas_ccopy n x 1 y 1)
581              y)))
582
583        (define (zcopy x)
584          (let ((n (fx/ (f64vector-length x) 2)))
585            (let ((y  (make-f64vector (fx* 2 n))))
586              (cblas_zcopy n x 1 y 1)
587              y)))
588
589
590        (define-syntax icopy-wrapper
591          (er-macro-transformer
592           (lambda (x r c)
593             (let* ((copy            (cadr x))
594                    (vector-length   (caddr x))
595                    (make-vector     (cadddr x))
596                    (name            copy)
597                    (%define         (r 'define))
598                    (%let            (r 'let))
599                    (%cond           (r 'cond))
600                    (%or             (r 'or))
601                    (%if             (r 'if))
602                    (%let-optionals  (r 'let-optionals)))
603               
604               `(,%define (,name n x . rest)
605                          (,%let-optionals rest ((y #f) (offsetX 0) (offsetY 0) (incX 1) (incY 1))
606                                           (,%let ((xlen  (,vector-length x))
607                                                   (ylen (,%if y (,vector-length y) (fx- n offsetX))))
608                                                  (,%cond ((not (fx= n xlen))
609                                                           (error ',name " n is not equal to the length of X (" xlen ")"))
610                                                          ((fx< offsetX 0) 
611                                                           (error ',name "offset of vector X (" offsetX ") is negative"))
612                                                          ((fx>= offsetX xlen)
613                                                           (error ',name "offset of vector X (" offsetX ") is greater than or equal to its length: " xlen))
614                                                          ((fx< offsetX 0) 
615                                                           (error ',name "offset of vector X (" offsetX ") is negative"))
616                                                          ((fx>= offsetY ylen)
617                                                           (error ',name "offset of vector Y (" offsetY ") is greater than or equal to its length: " ylen))
618                                                          ((fx> (- ylen offsetY) (- xlen offsetX))
619                                                           (error ',name "range of vector Y (" (- ylen offsetY) 
620                                                                  ") is greater than range of vector X: " ( - xlen offsetX))))
621                                                  (,%let ((y (,%or y (,make-vector ylen))))
622                                                         (,copy n x incX offsetX y incY offsetY)
623                                                         y))))))
624           ))
625
626        (icopy-wrapper sicopy f32vector-length make-f32vector)
627        (icopy-wrapper dicopy f64vector-length make-f64vector)
628        (icopy-wrapper cicopy 
629                       (lambda (x) (fx/ (f32vector-length x) 2))
630                       (lambda (n) (make-f32vector (fx* 2 n))))
631        (icopy-wrapper zicopy 
632                       (lambda (x) (fx/ (f64vector-length x) 2))
633                       (lambda (n) (make-f64vector (fx* 2 n))))
634
635
636
637
638
639        (bind* #<<EOF
640
641               /*
642               * ===========================================================================
643               * Prototypes for level 1 BLAS functions (complex are recast as routines)
644               * ===========================================================================
645               */
646               float  cblas_sdsdot(const int N, const float alpha, const float *X,
647                                         const int incX, const float *Y, const int incY);
648               double cblas_dsdot(const int N, const float *X, const int incX, const float *Y,
649                                        const int incY);
650               float  cblas_sdot(const int N, const float  *X, const int incX,
651                                       const float  *Y, const int incY);
652               double cblas_ddot(const int N, const double *X, const int incX,
653                                       const double *Y, const int incY);
654
655               /*
656               * Functions having prefixes Z and C only
657               */
658               void   cblas_cdotu_sub(const int N, const CCOMPLEX *X, const int incX,
659                                            const CCOMPLEX *Y, const int incY, CCOMPLEX *dotu);
660               void   cblas_cdotc_sub(const int N, const CCOMPLEX *X, const int incX,
661                                            const CCOMPLEX *Y, const int incY, CCOMPLEX *dotc);
662
663               void   cblas_zdotu_sub(const int N, const ZCOMPLEX *X, const int incX,
664                                            const ZCOMPLEX *Y, const int incY, ZCOMPLEX *dotu);
665               void   cblas_zdotc_sub(const int N, const ZCOMPLEX *X, const int incX,
666                                            const ZCOMPLEX *Y, const int incY, ZCOMPLEX *dotc);
667
668
669               /*
670               * Functions having prefixes S D SC DZ
671               */
672               float  cblas_snrm2(const int N, const float *X, const int incX);
673               float  cblas_sasum(const int N, const float *X, const int incX);
674
675               double cblas_dnrm2(const int N, const double *X, const int incX);
676               double cblas_dasum(const int N, const double *X, const int incX);
677
678               float  cblas_scnrm2(const int N, const CCOMPLEX *X, const int incX);
679               float  cblas_scasum(const int N, const CCOMPLEX *X, const int incX);
680
681               double cblas_dznrm2(const int N, const ZCOMPLEX *X, const int incX);
682               double cblas_dzasum(const int N, const ZCOMPLEX *X, const int incX);
683
684
685
686               /*
687               * Functions having standard 4 prefixes (S D C Z)
688               */
689               CBLAS_INDEX cblas_isamax(const int N, const float  *X, const int incX);
690               CBLAS_INDEX cblas_idamax(const int N, const double *X, const int incX);
691               CBLAS_INDEX cblas_icamax(const int N, const void   *X, const int incX);
692               CBLAS_INDEX cblas_izamax(const int N, const void   *X, const int incX);
693
694               /*
695               * ===========================================================================
696               * Prototypes for level 2 BLAS
697               * ===========================================================================
698               */
699
700               /* 
701               * Routines with standard 4 prefixes (S, D, C, Z)
702               */
703               void cblas_sgemv(const enum CBLAS_ORDER order,
704                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
705                                      const float alpha, const float *A, const int lda,
706                                      const float *X, const int incX, const float beta,
707                                      float *Y, const int incY);
708               void cblas_sgbmv(const enum CBLAS_ORDER order,
709                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
710                                      const int KL, const int KU, const float alpha,
711                                      const float *A, const int lda, const float *X,
712                                      const int incX, const float beta, float *Y, const int incY);
713               void cblas_strmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
714                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
715                                      const int N, const float *A, const int lda, 
716                                      float *X, const int incX);
717               void cblas_stbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
718                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
719                                      const int N, const int K, const float *A, const int lda, 
720                                      float *X, const int incX);
721               void cblas_stpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
722                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
723                                      const int N, const float *Ap, float *X, const int incX);
724               void cblas_strsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
725                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
726                                      const int N, const float *A, const int lda, float *X,
727                                      const int incX);
728               void cblas_stbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
729                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
730                                      const int N, const int K, const float *A, const int lda,
731                                      float *X, const int incX);
732               void cblas_stpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
733                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
734                                      const int N, const float *Ap, float *X, const int incX);
735
736               void cblas_dgemv(const enum CBLAS_ORDER order,
737                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
738                                      const double alpha, const double *A, const int lda,
739                                      const double *X, const int incX, const double beta,
740                                      double *Y, const int incY);
741               void cblas_dgbmv(const enum CBLAS_ORDER order,
742                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
743                                      const int KL, const int KU, const double alpha,
744                                      const double *A, const int lda, const double *X,
745                                      const int incX, const double beta, double *Y, const int incY);
746               void cblas_dtrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
747                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
748                                      const int N, const double *A, const int lda, 
749                                      double *X, const int incX);
750               void cblas_dtbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
751                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
752                                      const int N, const int K, const double *A, const int lda, 
753                                      double *X, const int incX);
754               void cblas_dtpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
755                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
756                                      const int N, const double *Ap, double *X, const int incX);
757               void cblas_dtrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
758                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
759                                      const int N, const double *A, const int lda, double *X,
760                                      const int incX);
761               void cblas_dtbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
762                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
763                                      const int N, const int K, const double *A, const int lda,
764                                      double *X, const int incX);
765               void cblas_dtpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
766                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
767                                      const int N, const double *Ap, double *X, const int incX);
768
769               void cblas_cgemv(const enum CBLAS_ORDER order,
770                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
771                                      const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
772                                      const CCOMPLEX *X, const int incX, const CCOMPLEX *beta,
773                                      CCOMPLEX *Y, const int incY);
774               void cblas_cgbmv(const enum CBLAS_ORDER order,
775                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
776                                      const int KL, const int KU, const CCOMPLEX *alpha,
777                                      const CCOMPLEX *A, const int lda, const CCOMPLEX *X,
778                                      const int incX, const CCOMPLEX *beta, CCOMPLEX *Y, const int incY);
779               void cblas_ctrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
780                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
781                                      const int N, const CCOMPLEX *A, const int lda, 
782                                      CCOMPLEX *X, const int incX);
783               void cblas_ctbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
784                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
785                                      const int N, const int K, const CCOMPLEX *A, const int lda, 
786                                      CCOMPLEX *X, const int incX);
787               void cblas_ctpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
788                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
789                                      const int N, const CCOMPLEX *Ap, CCOMPLEX *X, const int incX);
790               void cblas_ctrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
791                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
792                                      const int N, const CCOMPLEX *A, const int lda, CCOMPLEX *X,
793                                      const int incX);
794               void cblas_ctbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
795                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
796                                      const int N, const int K, const CCOMPLEX *A, const int lda,
797                                      CCOMPLEX *X, const int incX);
798               void cblas_ctpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
799                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
800                                      const int N, const CCOMPLEX *Ap, CCOMPLEX *X, const int incX);
801
802               void cblas_zgemv(const enum CBLAS_ORDER order,
803                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
804                                      const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
805                                      const ZCOMPLEX *X, const int incX, const ZCOMPLEX *beta,
806                                      ZCOMPLEX *Y, const int incY);
807               void cblas_zgbmv(const enum CBLAS_ORDER order,
808                                      const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
809                                      const int KL, const int KU, const ZCOMPLEX *alpha,
810                                      const ZCOMPLEX *A, const int lda, const ZCOMPLEX *X,
811                                      const int incX, const ZCOMPLEX *beta, ZCOMPLEX *Y, const int incY);
812               void cblas_ztrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
813                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
814                                      const int N, const ZCOMPLEX *A, const int lda, 
815                                      ZCOMPLEX *X, const int incX);
816               void cblas_ztbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
817                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
818                                      const int N, const int K, const ZCOMPLEX *A, const int lda, 
819                                      ZCOMPLEX *X, const int incX);
820               void cblas_ztpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
821                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
822                                      const int N, const ZCOMPLEX *Ap, ZCOMPLEX *X, const int incX);
823               void cblas_ztrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
824                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
825                                      const int N, const ZCOMPLEX *A, const int lda, ZCOMPLEX *X,
826                                      const int incX);
827               void cblas_ztbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
828                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
829                                      const int N, const int K, const ZCOMPLEX *A, const int lda,
830                                      ZCOMPLEX *X, const int incX);
831               void cblas_ztpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
832                                      const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
833                                      const int N, const ZCOMPLEX *Ap, ZCOMPLEX *X, const int incX);
834
835
836               /* 
837               * Routines with S and D prefixes only
838               */
839               void cblas_ssymv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
840                                      const int N, const float alpha, const float *A,
841                                      const int lda, const float *X, const int incX,
842                                      const float beta, float *Y, const int incY);
843               void cblas_ssbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
844                                      const int N, const int K, const float alpha, const float *A,
845                                      const int lda, const float *X, const int incX,
846                                      const float beta, float *Y, const int incY);
847               void cblas_sspmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
848                                      const int N, const float alpha, const float *Ap,
849                                      const float *X, const int incX,
850                                      const float beta, float *Y, const int incY);
851               void cblas_sger(const enum CBLAS_ORDER order, const int M, const int N,
852                                     const float alpha, const float *X, const int incX,
853                                     const float *Y, const int incY, float *A, const int lda);
854               void cblas_ssyr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
855                                     const int N, const float alpha, const float *X,
856                                     const int incX, float *A, const int lda);
857               void cblas_sspr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
858                                     const int N, const float alpha, const float *X,
859                                     const int incX, float *Ap);
860               void cblas_ssyr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
861                                      const int N, const float alpha, const float *X,
862                                      const int incX, const float *Y, const int incY, float *A,
863                                      const int lda);
864               void cblas_sspr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
865                                      const int N, const float alpha, const float *X,
866                                      const int incX, const float *Y, const int incY, float *A);
867
868               void cblas_dsymv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
869                                      const int N, const double alpha, const double *A,
870                                      const int lda, const double *X, const int incX,
871                                      const double beta, double *Y, const int incY);
872               void cblas_dsbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
873                                      const int N, const int K, const double alpha, const double *A,
874                                      const int lda, const double *X, const int incX,
875                                      const double beta, double *Y, const int incY);
876               void cblas_dspmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
877                                      const int N, const double alpha, const double *Ap,
878                                      const double *X, const int incX,
879                                      const double beta, double *Y, const int incY);
880               void cblas_dger(const enum CBLAS_ORDER order, const int M, const int N,
881                                     const double alpha, const double *X, const int incX,
882                                     const double *Y, const int incY, double *A, const int lda);
883               void cblas_dsyr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
884                                     const int N, const double alpha, const double *X,
885                                     const int incX, double *A, const int lda);
886               void cblas_dspr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
887                                     const int N, const double alpha, const double *X,
888                                     const int incX, double *Ap);
889               void cblas_dsyr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
890                                      const int N, const double alpha, const double *X,
891                                      const int incX, const double *Y, const int incY, double *A,
892                                      const int lda);
893               void cblas_dspr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
894                                      const int N, const double alpha, const double *X,
895                                      const int incX, const double *Y, const int incY, double *A);
896
897
898               /* 
899               * Routines with C and Z prefixes only
900               */
901               void cblas_chemv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
902                                      const int N, const CCOMPLEX *alpha, const CCOMPLEX *A,
903                                      const int lda, const CCOMPLEX *X, const int incX,
904                                      const CCOMPLEX *beta, CCOMPLEX *Y, const int incY);
905               void cblas_chbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
906                                      const int N, const int K, const CCOMPLEX *alpha, const CCOMPLEX *A,
907                                      const int lda, const CCOMPLEX *X, const int incX,
908                                      const CCOMPLEX *beta, CCOMPLEX *Y, const int incY);
909               void cblas_chpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
910                                      const int N, const CCOMPLEX *alpha, const CCOMPLEX *Ap,
911                                      const CCOMPLEX *X, const int incX,
912                                      const CCOMPLEX *beta, CCOMPLEX *Y, const int incY);
913               void cblas_cgeru(const enum CBLAS_ORDER order, const int M, const int N,
914                                      const CCOMPLEX *alpha, const CCOMPLEX *X, const int incX,
915                                      const CCOMPLEX *Y, const int incY, CCOMPLEX *A, const int lda);
916               void cblas_cgerc(const enum CBLAS_ORDER order, const int M, const int N,
917                                      const CCOMPLEX *alpha, const CCOMPLEX *X, const int incX,
918                                      const CCOMPLEX *Y, const int incY, CCOMPLEX *A, const int lda);
919               void cblas_cher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
920                                     const int N, const float alpha, const CCOMPLEX *X, const int incX,
921                                     CCOMPLEX *A, const int lda);
922               void cblas_chpr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
923                                     const int N, const float alpha, const CCOMPLEX *X,
924                                     const int incX, CCOMPLEX *A);
925               void cblas_cher2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N,
926                                      const CCOMPLEX *alpha, const CCOMPLEX *X, const int incX,
927                                      const CCOMPLEX *Y, const int incY, CCOMPLEX *A, const int lda);
928               void cblas_chpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N,
929                                      const CCOMPLEX *alpha, const CCOMPLEX *X, const int incX,
930                                      const CCOMPLEX *Y, const int incY, CCOMPLEX *Ap);
931
932               void cblas_zhemv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
933                                      const int N, const ZCOMPLEX *alpha, const ZCOMPLEX *A,
934                                      const int lda, const ZCOMPLEX *X, const int incX,
935                                      const ZCOMPLEX *beta, ZCOMPLEX *Y, const int incY);
936               void cblas_zhbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
937                                      const int N, const int K, const ZCOMPLEX *alpha, const ZCOMPLEX *A,
938                                      const int lda, const ZCOMPLEX *X, const int incX,
939                                      const ZCOMPLEX *beta, ZCOMPLEX *Y, const int incY);
940               void cblas_zhpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
941                                      const int N, const ZCOMPLEX *alpha, const ZCOMPLEX *Ap,
942                                      const ZCOMPLEX *X, const int incX,
943                                      const ZCOMPLEX *beta, ZCOMPLEX *Y, const int incY);
944               void cblas_zgeru(const enum CBLAS_ORDER order, const int M, const int N,
945                                      const ZCOMPLEX *alpha, const ZCOMPLEX *X, const int incX,
946                                      const ZCOMPLEX *Y, const int incY, ZCOMPLEX *A, const int lda);
947               void cblas_zgerc(const enum CBLAS_ORDER order, const int M, const int N,
948                                      const ZCOMPLEX *alpha, const ZCOMPLEX *X, const int incX,
949                                      const ZCOMPLEX *Y, const int incY, ZCOMPLEX *A, const int lda);
950               void cblas_zher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
951                                     const int N, const double alpha, const ZCOMPLEX *X, const int incX,
952                                     ZCOMPLEX *A, const int lda);
953               void cblas_zhpr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
954                                     const int N, const double alpha, const ZCOMPLEX *X,
955                                     const int incX, ZCOMPLEX *A);
956               void cblas_zher2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N,
957                                      const ZCOMPLEX *alpha, const ZCOMPLEX *X, const int incX,
958                                      const ZCOMPLEX *Y, const int incY, ZCOMPLEX *A, const int lda);
959               void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N,
960                                      const ZCOMPLEX *alpha, const ZCOMPLEX *X, const int incX,
961                                      const ZCOMPLEX *Y, const int incY, ZCOMPLEX *Ap);
962
963               /*
964               * ===========================================================================
965               * Prototypes for level 3 BLAS
966               * ===========================================================================
967               */
968
969               /* 
970               * Routines with standard 4 prefixes (S, D, C, Z)
971               */
972               void cblas_sgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA,
973                                      const enum CBLAS_TRANSPOSE TransB, const int M, const int N,
974                                      const int K, const float alpha, const float *A,
975                                      const int lda, const float *B, const int ldb,
976                                      const float beta, float *C, const int ldc);
977               void cblas_ssymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
978                                      const enum CBLAS_UPLO Uplo, const int M, const int N,
979                                      const float alpha, const float *A, const int lda,
980                                      const float *B, const int ldb, const float beta,
981                                      float *C, const int ldc);
982               void cblas_ssyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
983                                      const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
984                                      const float alpha, const float *A, const int lda,
985                                      const float beta, float *C, const int ldc);
986               void cblas_ssyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
987                                       const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
988                                       const float alpha, const float *A, const int lda,
989                                       const float *B, const int ldb, const float beta,
990                                       float *C, const int ldc);
991               void cblas_strmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
992                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
993                                      const enum CBLAS_DIAG Diag, const int M, const int N,
994                                      const float alpha, const float *A, const int lda,
995                                      float *B, const int ldb);
996               void cblas_strsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
997                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
998                                      const enum CBLAS_DIAG Diag, const int M, const int N,
999                                      const float alpha, const float *A, const int lda,
1000                                      float *B, const int ldb);
1001
1002               void cblas_dgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA,
1003                                      const enum CBLAS_TRANSPOSE TransB, const int M, const int N,
1004                                      const int K, const double alpha, const double *A,
1005                                      const int lda, const double *B, const int ldb,
1006                                      const double beta, double *C, const int ldc);
1007               void cblas_dsymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1008                                      const enum CBLAS_UPLO Uplo, const int M, const int N,
1009                                      const double alpha, const double *A, const int lda,
1010                                      const double *B, const int ldb, const double beta,
1011                                      double *C, const int ldc);
1012               void cblas_dsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1013                                      const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1014                                      const double alpha, const double *A, const int lda,
1015                                      const double beta, double *C, const int ldc);
1016               void cblas_dsyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1017                                       const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1018                                       const double alpha, const double *A, const int lda,
1019                                       const double *B, const int ldb, const double beta,
1020                                       double *C, const int ldc);
1021               void cblas_dtrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1022                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
1023                                      const enum CBLAS_DIAG Diag, const int M, const int N,
1024                                      const double alpha, const double *A, const int lda,
1025                                      double *B, const int ldb);
1026               void cblas_dtrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1027                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
1028                                      const enum CBLAS_DIAG Diag, const int M, const int N,
1029                                      const double alpha, const double *A, const int lda,
1030                                      double *B, const int ldb);
1031
1032               void cblas_cgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA,
1033                                      const enum CBLAS_TRANSPOSE TransB, const int M, const int N,
1034                                      const int K, const CCOMPLEX *alpha, const CCOMPLEX *A,
1035                                      const int lda, const CCOMPLEX *B, const int ldb,
1036                                      const CCOMPLEX *beta, CCOMPLEX *C, const int ldc);
1037               void cblas_csymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1038                                      const enum CBLAS_UPLO Uplo, const int M, const int N,
1039                                      const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
1040                                      const CCOMPLEX *B, const int ldb, const CCOMPLEX *beta,
1041                                      CCOMPLEX *C, const int ldc);
1042               void cblas_csyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1043                                      const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1044                                      const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
1045                                      const CCOMPLEX *beta, CCOMPLEX *C, const int ldc);
1046               void cblas_csyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1047                                       const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1048                                       const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
1049                                       const CCOMPLEX *B, const int ldb, const CCOMPLEX *beta,
1050                                       CCOMPLEX *C, const int ldc);
1051               void cblas_ctrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1052                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
1053                                      const enum CBLAS_DIAG Diag, const int M, const int N,
1054                                      const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
1055                                      CCOMPLEX *B, const int ldb);
1056               void cblas_ctrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1057                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
1058                                      const enum CBLAS_DIAG Diag, const int M, const int N,
1059                                      const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
1060                                      CCOMPLEX *B, const int ldb);
1061
1062               void cblas_zgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA,
1063                                      const enum CBLAS_TRANSPOSE TransB, const int M, const int N,
1064                                      const int K, const ZCOMPLEX *alpha, const ZCOMPLEX *A,
1065                                      const int lda, const ZCOMPLEX *B, const int ldb,
1066                                      const ZCOMPLEX *beta, ZCOMPLEX *C, const int ldc);
1067               void cblas_zsymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1068                                      const enum CBLAS_UPLO Uplo, const int M, const int N,
1069                                      const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
1070                                      const ZCOMPLEX *B, const int ldb, const ZCOMPLEX *beta,
1071                                      ZCOMPLEX *C, const int ldc);
1072               void cblas_zsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1073                                      const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1074                                      const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
1075                                      const ZCOMPLEX *beta, ZCOMPLEX *C, const int ldc);
1076               void cblas_zsyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1077                                       const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1078                                       const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
1079                                       const ZCOMPLEX *B, const int ldb, const ZCOMPLEX *beta,
1080                                       ZCOMPLEX *C, const int ldc);
1081               void cblas_ztrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1082                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
1083                                      const enum CBLAS_DIAG Diag, const int M, const int N,
1084                                      const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
1085                                      ZCOMPLEX *B, const int ldb);
1086               void cblas_ztrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1087                                      const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA,
1088                                      const enum CBLAS_DIAG Diag, const int M, const int N,
1089                                      const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
1090                                      ZCOMPLEX *B, const int ldb);
1091
1092
1093               /* 
1094               * Routines with prefixes C and Z only
1095               */
1096               void cblas_chemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1097                                      const enum CBLAS_UPLO Uplo, const int M, const int N,
1098                                      const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
1099                                      const CCOMPLEX *B, const int ldb, const CCOMPLEX *beta,
1100                                      CCOMPLEX *C, const int ldc);
1101               void cblas_cherk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1102                                      const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1103                                      const float alpha, const CCOMPLEX *A, const int lda,
1104                                      const float beta, CCOMPLEX *C, const int ldc);
1105               void cblas_cher2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1106                                       const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1107                                       const CCOMPLEX *alpha, const CCOMPLEX *A, const int lda,
1108                                       const CCOMPLEX *B, const int ldb, const float beta,
1109                                       CCOMPLEX *C, const int ldc);
1110
1111               void cblas_zhemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side,
1112                                      const enum CBLAS_UPLO Uplo, const int M, const int N,
1113                                      const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
1114                                      const ZCOMPLEX *B, const int ldb, const ZCOMPLEX *beta,
1115                                      ZCOMPLEX *C, const int ldc);
1116               void cblas_zherk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1117                                      const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1118                                      const double alpha, const ZCOMPLEX *A, const int lda,
1119                                      const double beta, ZCOMPLEX *C, const int ldc);
1120               void cblas_zher2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
1121                                       const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
1122                                       const ZCOMPLEX *alpha, const ZCOMPLEX *A, const int lda,
1123                                       const ZCOMPLEX *B, const int ldb, const double beta,
1124                                       ZCOMPLEX *C, const int ldc);
1125
1126
1127               /* Offset variants of ger routines */
1128
1129               void cblas_siger(const enum CBLAS_ORDER order, const int M, const int N,
1130                                      const float alpha, 
1131                                      const float *X, const int incX, const int offsetX,
1132                                      const float *Y, const int incY, const int offsetY,
1133                                      float *A, const int lda)
1134               {
1135
1136                cblas_sger(order, M, N, alpha, X+offsetX, incX, Y+offsetY, incY, A, lda);
1137                          }
1138
1139               void cblas_diger(const enum CBLAS_ORDER order, const int M, const int N,
1140                                      const double alpha, 
1141                                      const double *X, const int incX, const int offsetX,
1142                                      const double *Y, const int incY, const int offsetY,
1143                                      double *A, const int lda)
1144               {
1145
1146                cblas_dger(order, M, N, alpha, X+offsetX, incX, Y+offsetY, incY, A, lda);
1147                          }
1148
1149
1150               /* "Standardize" some procedure names */
1151
1152               float  cblas_cnrm2(const int N, const CCOMPLEX *X, const int incX)
1153               {
1154                return cblas_scnrm2(N,X,incX);
1155                       }
1156
1157               double cblas_znrm2(const int N, const ZCOMPLEX *X, const int incX)
1158               {
1159                return cblas_dznrm2(N,X,incX);
1160                       }
1161
1162
1163               float  cblas_casum(const int N, const CCOMPLEX *X, const int incX)
1164               {
1165                return cblas_scasum(N,X,incX);
1166                       }
1167
1168               double  cblas_zasum(const int N, const ZCOMPLEX *X, const int incX)
1169               {
1170                return cblas_dzasum(N,X,incX);
1171                       }
1172
1173               CBLAS_INDEX cblas_samax(const int N, const float  *X, const int incX)
1174               {
1175                return cblas_isamax(N,X,incX);
1176                       }
1177
1178               CBLAS_INDEX cblas_damax(const int N, const double *X, const int incX)
1179               {
1180                return cblas_idamax(N,X,incX);
1181                       }
1182
1183               CBLAS_INDEX cblas_camax(const int N, const void   *X, const int incX)
1184               {
1185                return cblas_icamax(N,X,incX);
1186                       }
1187
1188               CBLAS_INDEX cblas_zamax(const int N, const void   *X, const int incX)
1189               {
1190                return cblas_izamax(N,X,incX);
1191                       }
1192
1193               void   cblas_cdotu(const int N, const CCOMPLEX *X, const int incX,
1194                                        const CCOMPLEX *Y, const int incY, CCOMPLEX *dotu)
1195               {
1196                cblas_cdotu_sub(N,X,incX,Y,incY,dotu);
1197                               }
1198
1199               void   cblas_cdotc(const int N, const CCOMPLEX *X, const int incX,
1200                                        const CCOMPLEX *Y, const int incY, CCOMPLEX *dotc)
1201               {
1202                cblas_cdotc_sub(N,X,incX,Y,incY,dotc);
1203                               }
1204
1205               void   cblas_zdotu(const int N, const ZCOMPLEX *X, const int incX,
1206                                        const ZCOMPLEX *Y, const int incY, ZCOMPLEX *dotu)
1207               {
1208                cblas_zdotu_sub(N,X,incX,Y,incY,dotu);
1209                               }
1210
1211               void   cblas_zdotc(const int N, const ZCOMPLEX *X, const int incX,
1212                                        const ZCOMPLEX *Y, const int incY, ZCOMPLEX *dotc)
1213               {
1214                cblas_zdotc_sub(N,X,incX,Y,incY,dotc);
1215                               }
1216EOF
1217               )
1218
1219
1220
1221        (define-syntax blas-level3-wrap
1222          (er-macro-transformer
1223           (lambda (x r c)
1224             (let* ((fn      (cadr x))
1225                    (ret     (caddr x))
1226                    (err     (cadddr x))
1227                    (vsize   (car (cddddr x)))
1228                    (copy    (cadr (cddddr x)))
1229                    (cfname  (string->symbol (conc "cblas_" (symbol->string (car fn)))))
1230                    (fname   (string->symbol (conc (if vsize "" "unsafe-") 
1231                                                   (symbol->string (car fn))
1232                                                   (if copy "" "!"))))
1233                    (%define         (r 'define))
1234                    (%begin          (r 'begin))
1235                    (%let            (r 'let))
1236                    (%cond           (r 'cond))
1237                    (%or             (r 'or))
1238                    (%if             (r 'if))
1239                    (%let-optionals  (r 'let-optionals))
1240                   
1241                    (ka              (r 'ka))
1242                    (kb              (r 'kb))
1243                    (kc              (r 'kc))
1244                    (asize           (r 'asize))
1245                    (bsize           (r 'bsize))
1246                    (csize           (r 'csize))
1247                   
1248                    (args   (reverse (cdr fn)))
1249
1250                    (fsig  (let loop ((args args) (sig 'rest))
1251                             (if (null? args) (cons fname sig)
1252                                 (let ((x (car args)))
1253                                   (let ((sig (case x 
1254                                                ((lda)     sig)
1255                                                ((ldb)     sig)
1256                                                ((ldc)     sig)
1257                                                (else      (cons x sig)))))
1258                                     (loop (cdr args) sig))))))
1259
1260                    (opts  (append
1261                            (if (memq 'lda fn) 
1262                                `((lda 
1263                                   ,(cond ((memq 'side fn)
1264                                           `(,%if (= side Left) m n))
1265                                          ((memq 'transA fn)
1266                                           `(,%if (= transA NoTrans) k ,(if (memq 'm fn) 'm 'n)))
1267                                          ((memq 'trans fn)
1268                                           `(,%if (= trans NoTrans) k n))
1269                                          (else  
1270                                           (cond ((memq 'm fn) 'm) 
1271                                                 (else 'n))))))
1272                                `())
1273                            (if (memq 'ldb fn)   
1274                                `((ldb ,(cond ((memq 'transB fn) 
1275                                               `(,%if (= transB NoTrans) n k))
1276                                              ((memq 'trans fn) 
1277                                               `(,%if (= trans NoTrans) k n))
1278                                              (else 'n))))
1279                                `())
1280                            (if (memq 'ldc fn) 
1281                                `((ldc  n)) `()))))
1282
1283               `(,%define ,fsig 
1284                          (,%let-optionals rest ,opts
1285                                           ,(if vsize
1286                                                `(,%begin
1287                                                  (,%let ((,asize (,vsize a))
1288                                                          (,ka    ,(cond ((memq 'side fn) 
1289                                                                          `(,%if (= side Left) m n))
1290                                                                         ((memq 'transA fn) 
1291                                                                          `(,%if (= transA NoTrans) 
1292                                                                                 ,(if (memq 'm fn) 'm 'n) k))
1293                                                                         ((memq 'trans fn) 
1294                                                                          `(,%if (= trans NoTrans) 
1295                                                                                 ,(if (memq 'm fn) 'm 'n) k))
1296                                                                         (else (if (memq 'm fn) 'm 'n)))))
1297                                                         (,%if (< ,asize (fx* lda ,ka)) 
1298                                                               (error ',fname (conc "matrix A is allocated " ,asize " elements "
1299                                                                                         "but given dimensions are " ,ka " by " lda))))
1300                                                  ,(if (memq 'b fn)
1301                                                       `(,%let ((,bsize (,vsize b))
1302                                                                (,kb    ,(cond ((memq 'transB fn) 
1303                                                                                `(,%if (= transB NoTrans) k n))
1304                                                                               ((memq 'trans fn) 
1305                                                                                `(,%if (= trans NoTrans) n k))
1306                                                                               (else 'm))))
1307                                                               (,%if (< ,bsize (fx* ldb ,kb)) 
1308                                                                     (error ',fname (conc "matrix B is allocated " ,bsize " elements "
1309                                                                                               "but given dimensions are " ,kb " by " ldb))))
1310                                                       `(begin))
1311                                                  ,(if (memq 'c fn)
1312                                                       `(let ((,csize (,vsize c))
1313                                                              (,kc    ,(if (memq 'm fn) 'm 'n)))
1314                                                          (if (< ,csize (fx* ldc ,kc))
1315                                                              (error ',fname (conc "matrix C is allocated " ,csize " elements "
1316                                                                                        "but given dimensions are " ,kc " by " ldc))))
1317                                                       `(begin)))
1318                                                `(begin))
1319                                           (,%let ,(let loop ((fn fn) (bnds '()))
1320                                                     (if (null? fn) bnds
1321                                                         (let ((x (car fn)))
1322                                                           (let ((bnds (case x 
1323                                                                         (else    (if (and copy ret (memq x ret))
1324                                                                                      (cons `(,x (,copy ,x)) bnds)
1325                                                                                      bnds)))))
1326                                                             (loop (cdr fn) bnds)))))
1327                                                  (,%begin (,cfname . ,(cdr fn))
1328                                                           (values . ,ret)))))))
1329           )
1330          )
1331
1332       
1333        (define-syntax blas-level3-wrapx
1334          (er-macro-transformer
1335           (lambda (x r c)
1336             (let* ((fn     (cadr x))
1337                    (ret    (caddr x))
1338                    (errs   (cadddr x)))
1339               
1340               `(begin
1341                  (blas-level3-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1342                                    ,ret ,errs #f #f)
1343                  (blas-level3-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1344                                    ,ret ,errs #f #f)
1345                  (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1346                                    ,ret ,errs #f #f)
1347                  (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1348                                    ,ret ,errs #f #f)
1349                 
1350                  (blas-level3-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1351                                    ,ret ,errs f32vector-length #f)
1352                  (blas-level3-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1353                                    ,ret ,errs f64vector-length #f)
1354                  (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1355                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
1356                  (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1357                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
1358                 
1359                  (blas-level3-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1360                                    ,ret ,errs f32vector-length  scopy)
1361                  (blas-level3-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1362                                    ,ret ,errs f64vector-length  dcopy)
1363                  (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1364                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) ccopy)
1365                  (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1366                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) zcopy))))
1367
1368           )
1369          )
1370
1371        (define-syntax blas-level3-cz-wrapx
1372          (er-macro-transformer
1373           (lambda (x r c)
1374             (let* ((fn      (cadr x))
1375                    (ret     (caddr x))
1376                    (errs    (cadddr x)))
1377               
1378               `(begin
1379                  (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1380                                    ,ret ,errs #f #f)
1381                  (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1382                                    ,ret ,errs #f #f)
1383                 
1384                  (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1385                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
1386                  (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1387                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
1388                 
1389                  (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1390                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) ccopy)
1391                  (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1392                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) zcopy))))
1393           )
1394          )
1395
1396
1397        (blas-level3-wrapx (gemm order transA transB m n k alpha a lda b ldb beta c ldc)
1398                           (c)
1399                           (lambda (i) (cond ((= i 3)  "M < 0")
1400                                             ((= i 4)  "N < 0")
1401                                             ((= i 5)  "K < 0")
1402                                             ((= i 8)  "LDA < max(1, M or K)")
1403                                             ((= i 10) "LDB < max(1, N or K)")
1404                                             ((= i 13) "LDC < max(1, M)")
1405                                             (else (conc "error code " i)))))
1406       
1407        (blas-level3-wrapx (symm order side uplo  m n alpha a lda b ldb beta c ldc)
1408                           (c)
1409                           (lambda (i) (cond ((= i 3)  "M < 0")
1410                                             ((= i 4)  "N < 0")
1411                                             ((= i 5)  "K < 0")
1412                                             ((= i 8)  "LDA < max(1, M or K)")
1413                                             ((= i 10) "LDB < max(1, N or K)")
1414                                             ((= i 13) "LDC < max(1, M)")
1415                                             (else (conc "error code " i)))))
1416       
1417        (blas-level3-cz-wrapx (hemm order side uplo  m n alpha a lda b ldb beta c ldc)
1418                              (c)
1419                              (lambda (i) (cond ((= i 3)  "M < 0")
1420                                                ((= i 4)  "N < 0")
1421                                                ((= i 5)  "K < 0")
1422                                                ((= i 8)  "LDA < max(1, M or K)")
1423                                                ((= i 10) "LDB < max(1, N or K)")
1424                                                ((= i 13) "LDC < max(1, M)")
1425                                                (else (conc "error code " i)))))
1426       
1427        (blas-level3-wrapx (syrk order uplo trans n k alpha a lda beta c ldc)
1428                           (c)
1429                           (lambda (i) (cond ((= i 3)  "M < 0")
1430                                             ((= i 4)  "N < 0")
1431                                             ((= i 5)  "K < 0")
1432                                             ((= i 8)  "LDA < max(1, M or K)")
1433                                             ((= i 10) "LDB < max(1, N or K)")
1434                                             ((= i 13) "LDC < max(1, M)")
1435                                             (else (conc "error code " i)))))
1436       
1437        (blas-level3-cz-wrapx (herk order uplo trans n k alpha a lda beta c ldc)
1438                              (c)
1439                              (lambda (i) (cond ((= i 3)  "M < 0")
1440                                                ((= i 4)  "N < 0")
1441                                                ((= i 5)  "K < 0")
1442                                                ((= i 8)  "LDA < max(1, M or K)")
1443                                                ((= i 10) "LDB < max(1, N or K)")
1444                                                ((= i 13) "LDC < max(1, M)")
1445                                                (else (conc "error code " i)))))
1446       
1447       
1448        (blas-level3-wrapx (syr2k order uplo trans n k alpha a lda b ldb beta c ldc)
1449                           (c)
1450                           (lambda (i) (cond ((= i 3)  "M < 0")
1451                                             ((= i 4)  "N < 0")
1452                                             ((= i 5)  "K < 0")
1453                                             ((= i 8)  "LDA < max(1, M or K)")
1454                                             ((= i 10) "LDB < max(1, N or K)")
1455                                             ((= i 13) "LDC < max(1, M)")
1456                                             (else (conc "error code " i)))))
1457       
1458        (blas-level3-cz-wrapx (her2k order uplo trans n k alpha a lda b ldb beta c ldc)
1459                              (c)
1460                              (lambda (i) (cond ((= i 3)  "M < 0")
1461                                                ((= i 4)  "N < 0")
1462                                                ((= i 5)  "K < 0")
1463                                                ((= i 8)  "LDA < max(1, M or K)")
1464                                                ((= i 10) "LDB < max(1, N or K)")
1465                                                ((= i 13) "LDC < max(1, M)")
1466                                                (else (conc "error code " i)))))
1467       
1468        (blas-level3-wrapx (trmm order side uplo transA diag m n alpha a lda b ldb)
1469                           (b)
1470                           (lambda (i) (cond ((= i 3)  "M < 0")
1471                                             ((= i 4)  "N < 0")
1472                                             ((= i 5)  "K < 0")
1473                                             ((= i 8)  "LDA < max(1, M or K)")
1474                                             ((= i 10) "LDB < max(1, N or K)")
1475                                             ((= i 13) "LDC < max(1, M)")
1476                                             (else (conc "error code " i)))))
1477       
1478       
1479        (blas-level3-wrapx (trsm order side uplo transA diag m n alpha a lda b ldb)
1480                           (b)
1481                           (lambda (i) (cond ((= i 3)  "M < 0")
1482                                             ((= i 4)  "N < 0")
1483                                             ((= i 5)  "K < 0")
1484                                             ((= i 8)  "LDA < max(1, M or K)")
1485                                             ((= i 10) "LDB < max(1, N or K)")
1486                                             ((= i 13) "LDC < max(1, M)")
1487                                             (else (conc "error code " i)))))
1488       
1489
1490
1491        (define-syntax blas-level2-wrap
1492          (er-macro-transformer
1493           (lambda (x r c)
1494             (let* ((fn      (cadr x))
1495                    (ret     (caddr x))
1496                    (err     (cadddr x))
1497                    (vsize   (car (cddddr x)))
1498                    (copy    (cadr (cddddr x)))
1499                    (cfname  (string->symbol (conc "cblas_" (symbol->string (car fn)))))
1500                    (fname   (string->symbol (conc (if vsize "" "unsafe-") 
1501                                                   (symbol->string (car fn))
1502                                                   (if copy "" "!"))))
1503                    (%define         (r 'define))
1504                    (%begin          (r 'begin))
1505                    (%let            (r 'let))
1506                    (%cond           (r 'cond))
1507                    (%or             (r 'or))
1508                    (%if             (r 'if))
1509                    (%let-optionals  (r 'let-optionals))
1510
1511                    (ka              (r 'ka))
1512                    (asize           (r 'asize))
1513                    (apsize          (r 'apsize))
1514                    (apdim           (r 'apdim))
1515                    (xsize           (r 'xsize))
1516                    (ysize           (r 'ysize))
1517                    (xdim            (r 'xdim))
1518                    (ydim            (r 'ydim))
1519
1520                    (args  (reverse (cdr fn)))
1521
1522                    (fsig  (let loop ((args args) (sig 'rest))
1523                             (if (null? args) (cons fname sig)
1524                                 (let ((x (car args)))
1525                                   (let ((sig (case x
1526                                                ((lda)      sig)
1527                                                ((incx)     sig)
1528                                                ((incy)     sig)
1529                                                ((offx)     sig)
1530                                                ((offy)     sig)
1531                                                (else      (cons x sig)))))
1532                                     (loop (cdr args) sig))))))
1533
1534                    (opts  (append
1535                            (if (memq 'lda fn)  `((lda  ,(cond ((memq 'k fn) `(fx+ 1 k))
1536                                                               (else 'n)))) `())
1537                            (if (memq 'incy fn) `((incx 1) (incy 1) (offx 0) (offy 0)) `((incx 1)))))
1538                    )
1539
1540               `(,%define ,fsig 
1541                          (,%let-optionals rest ,opts
1542                                           ,(if vsize
1543                                                `(,%begin
1544                                                  ,(if (memq 'a fn)
1545                                                       `(,%let ((,asize (,vsize a))
1546                                                                (,ka    ,(if (memq 'm fn) 'm 'n)))
1547                                                               (,%if (< ,asize (fx* lda ,ka))
1548                                                                     (error ',fname (conc "matrix A is allocated " ,asize " elements "
1549                                                                                               "but given dimensions are " ,ka " by " lda))))
1550                                                       `(begin))
1551                                                  ,(if (memq 'ap fn)
1552                                                       `(,%let ((,apsize (,vsize ap))
1553                                                                (,apdim  (fx/ (fx* n (fx+ n 1)) 2)))
1554                                                               (,%if (< ,apsize ,apdim)
1555                                                                     (error ',fname (conc "vector Ap is allocated " ,apsize " elements "
1556                                                                                               "but given dimension is " ,apdim))))
1557                                                       `(begin))
1558                                                  ,(if (memq 'y fn)
1559                                                       `(,%let ((,ysize (,vsize y))
1560                                                                (,ydim  ,(if (and (memq 'm fn) (memq 'trans fn))
1561                                                                             `(,%if (= trans NoTrans) 
1562                                                                                    (fx+ 1 (fx* (abs incy) (fx- (fx+ offy m) 1)))
1563                                                                                    (fx+ 1 (fx* (abs incy) (fx- (fx+ offy n) 1))))
1564                                                                             `(fx+ 1 (fx* (abs incy) (fx- n 1))))))
1565                                                               (,%if (< ,ysize ,ydim)
1566                                                                     (error ',fname (conc "vector Y is allocated " ,ysize " elements "
1567                                                                                               "but given dimension is " ,ydim))))
1568                                                       `(begin))
1569                                                  ,(if (memq 'x fn)
1570                                                       `(,%let ((,xsize (,vsize x))
1571                                                                (,xdim  ,(if (and (memq 'm fn) (memq 'trans fn))
1572                                                                             `(if (= trans NoTrans) 
1573                                                                                  (fx+ 1 (fx* (abs incx) (fx- (fx+ offx n) 1)))
1574                                                                                  (fx+ 1 (fx* (abs incx) (fx- (fx+ offx m) 1))))
1575                                                                             `(fx+ 1 (fx* (abs incx) (fx- n 1))))))
1576                                                               (,%if (< ,xsize ,xdim)
1577                                                                     (error ',fname (conc "vector X is allocated " ,xsize " elements "
1578                                                                                               "but given dimension is " ,xdim))))
1579                                                       `(begin)))
1580                                                `(begin))
1581                                           (let ,(let loop ((fn fn) (bnds '()))
1582                                                   (if (null? fn) bnds
1583                                                       (let ((x (car fn)))
1584                                                         (let ((bnds (case x 
1585                                                                       (else    (if (and copy ret (memq x ret))
1586                                                                                    (cons `(,x (,copy ,x)) bnds)
1587                                                                                    bnds)))))
1588                                                           (loop (cdr fn) bnds)))))
1589                                             (begin (,cfname . ,(cdr fn))
1590                                                    (values . ,ret)))))))
1591           )
1592          )
1593
1594        (define-syntax blas-level2-wrapx
1595          (er-macro-transformer
1596           (lambda (x r c)
1597             (let* ((fn      (cadr x))
1598                    (ret     (caddr x))
1599                    (errs    (cadddr x)))
1600               
1601               `(begin
1602                  (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1603                                    ,ret ,errs #f #f)
1604                  (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1605                                    ,ret ,errs #f #f)
1606                  (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1607                                    ,ret ,errs #f #f)
1608                  (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1609                                    ,ret ,errs #f #f)
1610                 
1611                  (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1612                                    ,ret ,errs f32vector-length #f)
1613                  (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1614                                    ,ret ,errs f64vector-length #f)
1615                  (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1616                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
1617                  (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1618                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
1619                 
1620                  (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1621                                    ,ret ,errs f32vector-length  scopy)
1622                  (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1623                                    ,ret ,errs f64vector-length  dcopy)
1624                  (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1625                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) ccopy)
1626                  (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1627                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) zcopy)))
1628             ))
1629          )
1630
1631       
1632        (define-syntax blas-level2-sd-wrapx
1633          (er-macro-transformer
1634           (lambda (x r c)
1635             (let* ((fn      (cadr x))
1636                    (ret     (caddr x))
1637                    (errs    (cadddr x)))
1638               
1639               `(begin
1640                  (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1641                                    ,ret ,errs #f #f)
1642                  (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1643                                    ,ret ,errs #f #f)
1644                 
1645                  (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1646                                    ,ret ,errs f32vector-length #f)
1647                  (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1648                                    ,ret ,errs f64vector-length #f)
1649                 
1650                  (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
1651                                    ,ret ,errs f32vector-length  scopy)
1652                  (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
1653                                    ,ret ,errs f64vector-length  dcopy))))
1654           )
1655          )
1656       
1657       
1658        (define-syntax blas-level2-cz-wrapx
1659          (er-macro-transformer
1660           (lambda (x r c)
1661             (let* ((fn      (cadr x))
1662                    (ret     (caddr x))
1663                    (errs    (cadddr x)))
1664               
1665               `(begin
1666                  (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1667                                    ,ret ,errs #f #f)
1668                  (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1669                                    ,ret ,errs #f #f)
1670                 
1671                  (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1672                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
1673                  (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1674                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
1675                 
1676                  (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
1677                                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) ccopy)
1678                  (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
1679                                    ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) zcopy))))
1680           )
1681          )
1682       
1683       
1684        (blas-level2-wrapx (gemv order trans m n alpha a lda x incx beta y incy)
1685                           (y)
1686                           (lambda (i) (cond ((= i 2)  "M < 0")
1687                                             ((= i 3)  "N < 0")
1688                                             ((= i 6)  "LDA < max(1, M)")
1689                                             ((= i 8)  "INCX = 0")
1690                                             ((= i 11) "INCY < = 0")
1691                                             (else (conc "error code " i)))))
1692       
1693        (blas-level2-cz-wrapx (hemv order uplo n alpha a lda x incx beta y incy)
1694                              (y)
1695                              (lambda (i) (cond ((= i 2)  "M < 0")
1696                                                ((= i 3)  "N < 0")
1697                                                ((= i 6)  "LDA < max(1, M)")
1698                                                ((= i 8)  "INCX = 0")
1699                                                ((= i 11) "INCY < = 0")
1700                                                (else (conc "error code " i)))))
1701
1702        (blas-level2-cz-wrapx (hbmv order uplo n k alpha a lda x incx beta y incy)
1703                              (y)
1704                              (lambda (i) (cond ((= i 2)  "M < 0")
1705                                                ((= i 3)  "N < 0")
1706                                                ((= i 6)  "LDA < max(1, M)")
1707                                                ((= i 8)  "INCX = 0")
1708                                                ((= i 11) "INCY < = 0")
1709                                                (else (conc "error code " i)))))
1710
1711        (blas-level2-cz-wrapx (hpmv order uplo n alpha ap x incx beta y incy)
1712                              (y)
1713                              (lambda (i) (cond ((= i 2)  "M < 0")
1714                                                ((= i 3)  "N < 0")
1715                                                ((= i 6)  "LDA < max(1, M)")
1716                                                ((= i 8)  "INCX = 0")
1717                                                ((= i 11) "INCY < = 0")
1718                                                (else (conc "error code " i)))))
1719
1720        (blas-level2-sd-wrapx (symv order uplo n alpha a lda x incx beta y incy)
1721                              (y)
1722                              (lambda (i) (cond ((= i 2)  "M < 0")
1723                                                ((= i 3)  "N < 0")
1724                                                ((= i 6)  "LDA < max(1, M)")
1725                                                ((= i 8)  "INCX = 0")
1726                                                ((= i 11) "INCY < = 0")
1727                                                (else (conc "error code " i)))))
1728
1729        (blas-level2-sd-wrapx (sbmv order uplo n k alpha a lda x incx beta y incy)
1730                              (y)
1731                              (lambda (i) (cond ((= i 2)  "M < 0")
1732                                                ((= i 3)  "N < 0")
1733                                                ((= i 6)  "LDA < max(1, M)")
1734                                                ((= i 8)  "INCX = 0")
1735                                                ((= i 11) "INCY < = 0")
1736                                                (else (conc "error code " i)))))
1737
1738        (blas-level2-sd-wrapx (spmv order uplo n alpha ap x incx beta y incy)
1739                              (y)
1740                              (lambda (i) (cond ((= i 2)  "M < 0")
1741                                                ((= i 3)  "N < 0")
1742                                                ((= i 6)  "LDA < max(1, M)")
1743                                                ((= i 8)  "INCX = 0")
1744                                                ((= i 11) "INCY < = 0")
1745                                                (else (conc "error code " i)))))
1746
1747        (blas-level2-wrapx (trmv order uplo trans diag n a lda x incx)
1748                           (x)
1749                           (lambda (i) (cond ((= i 2)  "M < 0")
1750                                             ((= i 3)  "N < 0")
1751                                             ((= i 6)  "LDA < max(1, M)")
1752                                             ((= i 8)  "INCX = 0")
1753                                             ((= i 11) "INCY < = 0")
1754                                             (else (conc "error code " i)))))
1755
1756        (blas-level2-wrapx (tbmv order uplo trans diag n k a lda x incx)
1757                           (x)
1758                           (lambda (i) (cond ((= i 2)  "M < 0")
1759                                             ((= i 3)  "N < 0")
1760                                             ((= i 6)  "LDA < max(1, M)")
1761                                             ((= i 8)  "INCX = 0")
1762                                             ((= i 11) "INCY < = 0")
1763                                             (else (conc "error code " i)))))
1764
1765        (blas-level2-wrapx (tpmv order uplo trans diag n ap x incx)
1766                           (x)
1767                           (lambda (i) (cond ((= i 2)  "M < 0")
1768                                             ((= i 3)  "N < 0")
1769                                             ((= i 6)  "LDA < max(1, M)")
1770                                             ((= i 8)  "INCX = 0")
1771                                             ((= i 11) "INCY < = 0")
1772                                             (else (conc "error code " i)))))
1773
1774        (blas-level2-wrapx (trsv order uplo trans diag n a lda x incx)
1775                           (x)
1776                           (lambda (i) (cond ((= i 2)  "M < 0")
1777                                             ((= i 3)  "N < 0")
1778                                             ((= i 6)  "LDA < max(1, M)")
1779                                             ((= i 8)  "INCX = 0")
1780                                             ((= i 11) "INCY < = 0")
1781                                             (else (conc "error code " i)))))
1782
1783        (blas-level2-wrapx (tbsv order uplo trans diag n k a lda x incx)
1784                           (x)
1785                           (lambda (i) (cond ((= i 2)  "M < 0")
1786                                             ((= i 3)  "N < 0")
1787                                             ((= i 6)  "LDA < max(1, M)")
1788                                             ((= i 8)  "INCX = 0")
1789                                             ((= i 11) "INCY < = 0")
1790                                             (else (conc "error code " i)))))
1791       
1792        (blas-level2-wrapx (tpsv order uplo trans diag n ap x incx)
1793                           (x)
1794                           (lambda (i) (cond ((= i 2)  "M < 0")
1795                                             ((= i 3)  "N < 0")
1796                                             ((= i 6)  "LDA < max(1, M)")
1797                                             ((= i 8)  "INCX = 0")
1798                                             ((= i 11) "INCY < = 0")
1799                                             (else (conc "error code " i)))))
1800       
1801        (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda)
1802                              (a)
1803                              (lambda (i) (cond ((= i 2)  "M < 0")
1804                                                ((= i 3)  "N < 0")
1805                                                ((= i 6)  "LDA < max(1, M)")
1806                                                ((= i 8)  "INCX = 0")
1807                                                ((= i 11) "INCY < = 0")
1808                                                (else (conc "error code " i)))))
1809       
1810        (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda)
1811                              (a)
1812                              (lambda (i) (cond ((= i 2)  "M < 0")
1813                                                ((= i 3)  "N < 0")
1814                                                ((= i 6)  "LDA < max(1, M)")
1815                                                ((= i 8)  "INCX = 0")
1816                                                ((= i 11) "INCY < = 0")
1817                                                (else (conc "error code " i)))))
1818       
1819        (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda)
1820                              (a)
1821                              (lambda (i) (cond ((= i 2)  "M < 0")
1822                                                ((= i 3)  "N < 0")
1823                                                ((= i 6)  "LDA < max(1, M)")
1824                                                ((= i 8)  "INCX = 0")
1825                                                ((= i 11) "INCY < = 0")
1826                                                (else (conc "error code " i)))))
1827       
1828       
1829        (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda)
1830                              (a)
1831                              (lambda (i) (cond ((= i 2)  "M < 0")
1832                                                ((= i 3)  "N < 0")
1833                                                ((= i 6)  "LDA < max(1, M)")
1834                                                ((= i 8)  "INCX = 0")
1835                                                ((= i 11) "INCY < = 0")
1836                                                (else (conc "error code " i)))))
1837       
1838        (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap)
1839                              (ap)
1840                              (lambda (i) (cond ((= i 2)  "M < 0")
1841                                                ((= i 3)  "N < 0")
1842                                                ((= i 6)  "LDA < max(1, M)")
1843                                                ((= i 8)  "INCX = 0")
1844                                                ((= i 11) "INCY < = 0")
1845                                                (else (conc "error code " i)))))
1846       
1847        (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda)
1848                              (a)
1849                              (lambda (i) (cond ((= i 2)  "M < 0")
1850                                                ((= i 3)  "N < 0")
1851                                                ((= i 6)  "LDA < max(1, M)")
1852                                                ((= i 8)  "INCX = 0")
1853                                                ((= i 11) "INCY < = 0")
1854                                                (else (conc "error code " i)))))
1855       
1856        (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap)
1857                              (ap)
1858                              (lambda (i) (cond ((= i 2)  "M < 0")
1859                                                ((= i 3)  "N < 0")
1860                                                ((= i 6)  "LDA < max(1, M)")
1861                                                ((= i 8)  "INCX = 0")
1862                                                ((= i 11) "INCY < = 0")
1863                                                (else (conc "error code " i)))))
1864       
1865        (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda)
1866                              (a)
1867                              (lambda (i) (cond ((= i 2)  "M < 0")
1868                                                ((= i 3)  "N < 0")
1869                                                ((= i 6)  "LDA < max(1, M)")
1870                                                ((= i 8)  "INCX = 0")
1871                                                ((= i 11) "INCY < = 0")
1872                                                (else (conc "error code " i)))))
1873       
1874        (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap)
1875                              (ap)
1876                              (lambda (i) (cond ((= i 2)  "M < 0")
1877                                                ((= i 3)  "N < 0")
1878                                                ((= i 6)  "LDA < max(1, M)")
1879                                                ((= i 8)  "INCX = 0")
1880                                                ((= i 11) "INCY < = 0")
1881                                                (else (conc "error code " i)))))
1882       
1883        (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda)
1884                              (a)
1885                              (lambda (i) (cond ((= i 2)  "M < 0")
1886                                                ((= i 3)  "N < 0")
1887                                                ((= i 6)  "LDA < max(1, M)")
1888                                                ((= i 8)  "INCX = 0")
1889                                                ((= i 11) "INCY < = 0")
1890                                                (else (conc "error code " i)))))
1891       
1892        (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda)
1893                              (a)
1894                              (lambda (i) (cond ((= i 2)  "M < 0")
1895                                                ((= i 3)  "N < 0")
1896                                                ((= i 6)  "LDA < max(1, M)")
1897                                                ((= i 8)  "INCX = 0")
1898                                                ((= i 11) "INCY < = 0")
1899                                                (else (conc "error code " i)))))
1900       
1901        (blas-level2-sd-wrapx (iger order m n alpha x incx offx y incy offy a lda)
1902                              (a)
1903                              (lambda (i) (cond ((= i 2)  "M < 0")
1904                                                ((= i 3)  "N < 0")
1905                                                ((= i 6)  "LDA < max(1, M)")
1906                                                ((= i 8)  "INCX = 0")
1907                                                ((= i 11) "INCY < = 0")
1908                                                (else (conc "error code " i)))))
1909       
1910        (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda)
1911                              (a)
1912                              (lambda (i) (cond ((= i 2)  "M < 0")
1913                                                ((= i 3)  "N < 0")
1914                                                ((= i 6)  "LDA < max(1, M)")
1915                                                ((= i 8)  "INCX = 0")
1916                                                ((= i 11) "INCY < = 0")
1917                                                (else (conc "error code " i)))))
1918       
1919        (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda)
1920                              (a)
1921                              (lambda (i) (cond ((= i 2)  "M < 0")
1922                                                ((= i 3)  "N < 0")
1923                                                ((= i 6)  "LDA < max(1, M)")
1924                                                ((= i 8)  "INCX = 0")
1925                                                ((= i 11) "INCY < = 0")
1926                                                (else (conc "error code " i)))))
1927       
1928       
1929        (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda)
1930                              (a)
1931                              (lambda (i) (cond ((= i 2)  "M < 0")
1932                                                ((= i 3)  "N < 0")
1933                                                ((= i 6)  "LDA < max(1, M)")
1934                                                ((= i 8)  "INCX = 0")
1935                                                ((= i 11) "INCY < = 0")
1936                                                (else (conc "error code " i)))))
1937       
1938        (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap)
1939                              (ap)
1940                              (lambda (i) (cond ((= i 2)  "M < 0")
1941                                                ((= i 3)  "N < 0")
1942                                                ((= i 6)  "LDA < max(1, M)")
1943                                                ((= i 8)  "INCX = 0")
1944                                                ((= i 11) "INCY < = 0")
1945                                                (else (conc "error code " i)))))
1946       
1947        (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda)
1948                              (a)
1949                              (lambda (i) (cond ((= i 2)  "M < 0")
1950                                                ((= i 3)  "N < 0")
1951                                                ((= i 6)  "LDA < max(1, M)")
1952                                                ((= i 8)  "INCX = 0")
1953                                                ((= i 11) "INCY < = 0")
1954                                                (else (conc "error code " i)))))
1955       
1956        (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap)
1957                              (ap)
1958                              (lambda (i) (cond ((= i 2)  "M < 0")
1959                                                ((= i 3)  "N < 0")
1960                                                ((= i 6)  "LDA < max(1, M)")
1961                                                ((= i 8)  "INCX = 0")
1962                                                ((= i 11) "INCY < = 0")
1963                                                (else (conc "error code " i)))))
1964       
1965        (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda)
1966                              (a)
1967                              (lambda (i) (cond ((= i 2)  "M < 0")
1968                                                ((= i 3)  "N < 0")
1969                                                ((= i 6)  "LDA < max(1, M)")
1970                                                ((= i 8)  "INCX = 0")
1971                                                ((= i 11) "INCY < = 0")
1972                                                (else (conc "error code " i)))))
1973       
1974        (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap)
1975                              (ap)
1976                              (lambda (i) (cond ((= i 2)  "M < 0")
1977                                                ((= i 3)  "N < 0")
1978                                                ((= i 6)  "LDA < max(1, M)")
1979                                                ((= i 8)  "INCX = 0")
1980                                                ((= i 11) "INCY < = 0")
1981                                                (else (conc "error code " i)))))
1982       
1983        (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda)
1984                              (a)
1985                              (lambda (i) (cond ((= i 2)  "M < 0")
1986                                                ((= i 3)  "N < 0")
1987                                                ((= i 6)  "LDA < max(1, M)")
1988                                                ((= i 8)  "INCX = 0")
1989                                                ((= i 11) "INCY < = 0")
1990                                                (else (conc "error code " i)))))
1991       
1992        (blas-level2-sd-wrapx (spr2 order uplo n alpha x incx y incy ap)
1993                              (ap)
1994                              (lambda (i) (cond ((= i 2)  "M < 0")
1995                                                ((= i 3)  "N < 0")
1996                                                ((= i 6)  "LDA < max(1, M)")
1997                                                ((= i 8)  "INCX = 0")
1998                                                ((= i 11) "INCY < = 0")
1999                                                (else (conc "error code " i)))))
2000       
2001       
2002
2003
2004        (define-syntax  blas-level1-wrap
2005          (er-macro-transformer
2006           (lambda (x r c)
2007             (let* ((fn            (cadr x))
2008                    (ret           (caddr x))
2009                    (err           (cadddr x))
2010                    (vsize         (car (cddddr x)))
2011                    (copy          (cadr (cddddr x)))
2012                    (make-return   (cddr (cddddr x)))
2013                    (cfname  (string->symbol (conc "cblas_" (symbol->string (car fn)))))
2014                    (fname   (string->symbol (conc (if vsize "" "unsafe-") 
2015                                                   (symbol->string (car fn))
2016                                                   (if copy "" "!"))))
2017                   
2018                    (%define         (r 'define))
2019                    (%begin          (r 'begin))
2020                    (%let            (r 'let))
2021                    (%cond           (r 'cond))
2022                    (%or             (r 'or))
2023                    (%if             (r 'if))
2024                    (%let-optionals  (r 'let-optionals))
2025
2026                    (asize           (r 'asize))
2027                    (apsize          (r 'apsize))
2028                    (apdim           (r 'apdim))
2029                    (xsize           (r 'xsize))
2030                    (ysize           (r 'ysize))
2031                    (xdim            (r 'xdim))
2032                    (ydim            (r 'ydim))
2033                    (psize           (r 'psize))
2034                    (pdim            (r 'pdim))
2035
2036                    (args   (reverse (cdr fn)))
2037
2038                    (fsig  (let loop ((args args) (sig 'rest))
2039                             (if (null? args) (cons fname sig)
2040                                 (let ((x (car args)))
2041                                   (let ((sig (case x
2042                                                ((incx)     sig)
2043                                                ((incy)     sig)
2044                                                ((dotu)     sig)
2045                                                ((dotc)     sig)
2046                                                ((offx)     sig)
2047                                                ((offy)     sig)
2048                                                (else      (cons x sig)))))
2049                                     (loop (cdr args) sig))))))
2050
2051                    (opts  (cond ((memq 'incy fn)  `((incx 1) (incy 1) (offx 0) (offy 0)))
2052                                 (else `((incx 1) (offx 0))))))
2053
2054               `(,%define ,fsig 
2055                          (,%let-optionals rest ,opts
2056                                           ,(if vsize
2057                                                `(,%begin
2058                                                  ,(if (memq 'y fn)
2059                                                       `(,%let ((,ysize (,vsize y))
2060                                                                (,ydim  (fx+ 1 (fx* (abs incy) (fx- (fx+ offy n) 1)))))
2061                                                               (,%if (< ,ysize ,ydim)
2062                                                                     (error ',fname (conc "vector Y is allocated " ,ysize " elements "
2063                                                                                               "but given dimension is " ,ydim))))
2064                                                       `(begin))
2065                                                  ,(if (memq 'x fn)
2066                                                       `(,%let ((,xsize (,vsize x))
2067                                                                (,xdim  (fx+ 1 (fx* (abs incx) (fx- (fx+ offx n) 1)))))
2068                                                               (,%if (< ,xsize ,xdim)
2069                                                                     (error ',fname (conc "vector X is allocated " ,xsize " elements "
2070                                                                                               "but given dimension is " ,xdim))))
2071                                                       `(begin))
2072                                                  ,(if (memq 'param fn)
2073                                                       `(,%let ((,psize (,vsize param))
2074                                                                (,pdim  5))
2075                                                               (,%if (< ,psize ,pdim)
2076                                                                     (error ',fname (conc "vector PARAM is allocated " ,psize " elements "
2077                                                                                               "but dimension must be " ,pdim))))
2078                                                       `(begin)))
2079                                               
2080                                                `(begin))
2081                                           (let ,(let loop ((fn fn) (bnds '()))
2082                                                   (if (null? fn) bnds
2083                                                       (let ((x (car fn)))
2084                                                         (let ((bnds (cond ((or (eq? x 'dotc) (eq? x 'dotu))
2085                                                                            (cons `(,x (,(car make-return))) bnds))
2086                                                                           ((and copy ret (memq x ret))
2087                                                                            (cons `(,x (,copy ,x)) bnds))
2088                                                                           (else bnds))))
2089                                                           (loop (cdr fn) bnds)))))
2090                                             ,(cond
2091                                               ((memq 'dotc fn)   `(begin (,cfname . ,(cdr fn))
2092                                                                          (values dotc)))
2093                                               ((memq 'dotu fn)   `(begin (,cfname . ,(cdr fn))
2094                                                                          (values dotu)))
2095                                               ((not ret)         `(,cfname . ,(cdr fn)))
2096                                               (else              `(begin (,cfname . ,(cdr fn))
2097                                                                          (values . ,ret)))))))))
2098           )
2099          )
2100
2101        (define-syntax blas-level1-wrapx
2102          (er-macro-transformer
2103           (lambda (x r c) 
2104             (let* ((fn      (cadr x))
2105                    (ret     (caddr x))
2106                    (errs    (cadddr x)))
2107               
2108               (if (not ret)
2109                   `(begin
2110                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2111                                        ,ret ,errs f32vector-length  scopy)
2112                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2113                                        ,ret ,errs f64vector-length  dcopy)
2114                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2115                                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) ccopy)
2116                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2117                                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) zcopy))
2118                   
2119                   `(begin
2120                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2121                                        ,ret ,errs #f #f)
2122                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2123                                        ,ret ,errs #f #f)
2124                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2125                                        ,ret ,errs #f #f)
2126                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2127                                        ,ret ,errs #f #f)
2128                     
2129                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2130                                        ,ret ,errs f32vector-length #f)
2131                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2132                                        ,ret ,errs f64vector-length #f)
2133                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2134                                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
2135                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2136                                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
2137                     
2138                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2139                                        ,ret ,errs f32vector-length  scopy)
2140                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2141                                        ,ret ,errs f64vector-length  dcopy)
2142                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2143                                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) ccopy)
2144                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2145                                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) zcopy))))
2146             ))
2147          )
2148
2149
2150        (define-syntax blas-level1-sd-wrapx
2151          (er-macro-transformer
2152           (lambda (x r c) 
2153             (let* ((fn      (cadr x))
2154                    (ret     (caddr x))
2155                    (errs    (cadddr x)))
2156               (if (not ret)
2157                   
2158                   `(begin
2159                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2160                                        ,ret ,errs f32vector-length  scopy)
2161                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2162                                        ,ret ,errs f64vector-length  dcopy))
2163                   
2164                   `(begin
2165                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2166                                        ,ret ,errs #f #f)
2167                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2168                                        ,ret ,errs #f #f)
2169                     
2170                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2171                                        ,ret ,errs f32vector-length #f)
2172                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2173                                        ,ret ,errs f64vector-length #f)
2174                     
2175                      (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn))
2176                                        ,ret ,errs f32vector-length  scopy)
2177                      (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn))
2178                                        ,ret ,errs f64vector-length  dcopy))))
2179             ))
2180          )
2181
2182        (define-syntax blas-level1-cz-wrapx
2183          (er-macro-transformer
2184           (lambda (x r c) 
2185             (let* ((fn      (cadr x))
2186                    (ret     (caddr x))
2187                    (errs    (cadddr x)))
2188               
2189               (if (not ret)
2190                   `(begin
2191                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2192                                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) 
2193                                        ccopy (lambda () (make-f32vector 2)))
2194                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2195                                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) 
2196                                        zcopy (lambda () (make-f64vector 2))))
2197                   
2198                   `(begin
2199                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2200                                        ,ret ,errs #f #f)
2201                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2202                                        ,ret ,errs #f #f)
2203                     
2204                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2205                                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
2206                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2207                                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
2208                     
2209                      (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn))
2210                                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) ccopy)
2211                      (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn))
2212                                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) zcopy))))
2213             ))
2214          )
2215
2216       
2217        (blas-level1-sd-wrapx (rot n x incx y incy c s)
2218                              (x y)
2219                              (lambda (i) (cond (conc "error code " i))))
2220       
2221        (blas-level1-sd-wrapx (rotm n x incx y incy param)
2222                              (x y)
2223                              (lambda (i) (cond (conc "error code " i))))
2224       
2225        (blas-level1-wrapx (swap n x incx y incy)
2226                           (x y)
2227                           (lambda (i) (cond (conc "error code " i))))
2228
2229        (blas-level1-wrapx (scal n alpha x incx)
2230                           (x)
2231                           (lambda (i) (cond (conc "error code " i))))
2232       
2233        (blas-level1-wrapx (axpy n alpha x incx y incy)
2234                           (y)
2235                           (lambda (i) (cond (conc "error code " i))))
2236       
2237        (blas-level1-wrapx (iaxpy n alpha x incx offx y incy offy)
2238                           (y)
2239                           (lambda (i) (cond (conc "error code " i))))
2240       
2241        (blas-level1-sd-wrapx (dot n x incx y incy)
2242                              #f
2243                              (lambda (i) (cond (conc "error code " i))))
2244       
2245        (blas-level1-cz-wrapx (dotu n x incx y incy dotu)
2246                              #f
2247                              (lambda (i) (cond (conc "error code " i))))
2248       
2249        (blas-level1-cz-wrapx (dotc n x incx y incy dotc)
2250                              #f
2251                              (lambda (i) (cond (conc "error code " i))))
2252       
2253        (blas-level1-wrapx (nrm2 n x incx)
2254                           #f
2255                           (lambda (i) (cond (conc "error code " i))))
2256       
2257        (blas-level1-wrapx (asum n x incx)
2258                           #f
2259                           (lambda (i) (cond (conc "error code " i))))
2260       
2261        (blas-level1-wrapx (amax n x incx)
2262                           #f
2263                           (lambda (i) (cond (conc "error code " i))))
2264
2265)
2266       
Note: See TracBrowser for help on using the repository browser.